src/language/data-io/data-list.c

   1 /* PSPP - computes sample statistics.
   2    Copyright (C) 1997-9, 2000, 2006 Free Software Foundation, Inc.
   3    Written by Ben Pfaff <blp@gnu.org>.
   4
   5    This program is free software; you can redistribute it and/or
   6    modify it under the terms of the GNU General Public License as
   7    published by the Free Software Foundation; either version 2 of the
   8    License, or (at your option) any later version.
   9
  10    This program is distributed in the hope that it will be useful, but
  11    WITHOUT ANY WARRANTY; without even the implied warranty of
  12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13    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, write to the Free Software
  17    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  18    02110-1301, USA. */
  19
  20 #include <config.h>
  21
  22 #include <ctype.h>
  23 #include <float.h>
  24 #include <stdio.h>
  25 #include <stdlib.h>
  26
  27 #include <data/case-source.h>
  28 #include <data/case.h>
  29 #include <data/data-in.h>
  30 #include <data/dictionary.h>
  31 #include <data/format.h>
  32 #include <data/settings.h>
  33 #include <data/variable.h>
  34 #include <language/command.h>
  35 #include <language/data-io/data-reader.h>
  36 #include <language/data-io/file-handle.h>
  37 #include <language/data-io/inpt-pgm.h>
  38 #include <language/lexer/lexer.h>
  39 #include <libpspp/alloc.h>
  40 #include <libpspp/compiler.h>
  41 #include <libpspp/message.h>
  42 #include <libpspp/message.h>
  43 #include <libpspp/misc.h>
  44 #include <libpspp/str.h>
  45 #include <output/table.h>
  46 #include <procedure.h>
  47
  48 #include "gettext.h"
  49 #define _(msgid) gettext (msgid)
  50 \f
  51 /* Utility function. */
  52
  53 /* Describes how to parse one variable. */
  54 struct dls_var_spec
  55   {
  56     struct dls_var_spec *next;  /* Next specification in list. */
  57
  58     /* Both free and fixed formats. */
  59     struct fmt_spec input;      /* Input format of this field. */
  60     struct variable *v;         /* Associated variable.  Used only in
  61                                    parsing.  Not safe later. */
  62     int fv;                     /* First value in case. */
  63
  64     /* Fixed format only. */
  65     int rec;                    /* Record number (1-based). */
  66     int fc, lc;                 /* Column numbers in record. */
  67
  68     /* Free format only. */
  69     char name[LONG_NAME_LEN + 1]; /* Name of variable. */
  70   };
  71
  72 /* Constants for DATA LIST type. */
  73 /* Must match table in cmd_data_list(). */
  74 enum
  75   {
  76     DLS_FIXED,
  77     DLS_FREE,
  78     DLS_LIST
  79   };
  80
  81 /* DATA LIST private data structure. */
  82 struct data_list_pgm
  83   {
  84     struct dls_var_spec *first, *last;  /* Variable parsing specifications. */
  85     struct dfm_reader *reader;  /* Data file reader. */
  86
  87     int type;                   /* A DLS_* constant. */
  88     struct variable *end;       /* Variable specified on END subcommand. */
  89     int rec_cnt;                /* Number of records. */
  90     size_t case_size;           /* Case size in bytes. */
  91     char *delims;               /* Delimiters if any; not null-terminated. */
  92     size_t delim_cnt;           /* Number of delimiter, or 0 for spaces. */
  93   };
  94
  95 static const struct case_source_class data_list_source_class;
  96
  97 static int parse_fixed (struct data_list_pgm *);
  98 static int parse_free (struct dls_var_spec **, struct dls_var_spec **);
  99 static void dump_fixed_table (const struct dls_var_spec *,
 100                               const struct file_handle *, int rec_cnt);
 101 static void dump_free_table (const struct data_list_pgm *,
 102                              const struct file_handle *);
 103 static void destroy_dls_var_spec (struct dls_var_spec *);
 104 static trns_free_func data_list_trns_free;
 105 static trns_proc_func data_list_trns_proc;
 106
 107 int
 108 cmd_data_list (void)
 109 {
 110   struct data_list_pgm *dls;
 111   int table = -1;                /* Print table if nonzero, -1=undecided. */
 112   struct file_handle *fh = fh_inline_file ();
 113
 114   if (!in_input_program ())
 115     discard_variables ();
 116
 117   dls = xmalloc (sizeof *dls);
 118   dls->reader = NULL;
 119   dls->type = -1;
 120   dls->end = NULL;
 121   dls->rec_cnt = 0;
 122   dls->delims = NULL;
 123   dls->delim_cnt = 0;
 124   dls->first = dls->last = NULL;
 125
 126   while (token != '/')
 127     {
 128       if (lex_match_id ("FILE"))
 129         {
 130           lex_match ('=');
 131           fh = fh_parse (FH_REF_FILE | FH_REF_INLINE);
 132           if (fh == NULL)
 133             goto error;
 134         }
 135       else if (lex_match_id ("RECORDS"))
 136         {
 137           lex_match ('=');
 138           lex_match ('(');
 139           if (!lex_force_int ())
 140             goto error;
 141           dls->rec_cnt = lex_integer ();
 142           lex_get ();
 143           lex_match (')');
 144         }
 145       else if (lex_match_id ("END"))
 146         {
 147           if (dls->end)
 148             {
 149               msg (SE, _("The END subcommand may only be specified once."));
 150               goto error;
 151             }
 152
 153           lex_match ('=');
 154           if (!lex_force_id ())
 155             goto error;
 156           dls->end = dict_lookup_var (default_dict, tokid);
 157           if (!dls->end)
 158             dls->end = dict_create_var_assert (default_dict, tokid, 0);
 159           lex_get ();
 160         }
 161       else if (token == T_ID)
 162         {
 163           if (lex_match_id ("NOTABLE"))
 164             table = 0;
 165           else if (lex_match_id ("TABLE"))
 166             table = 1;
 167           else
 168             {
 169               int type;
 170               if (lex_match_id ("FIXED"))
 171                 type = DLS_FIXED;
 172               else if (lex_match_id ("FREE"))
 173                 type = DLS_FREE;
 174               else if (lex_match_id ("LIST"))
 175                 type = DLS_LIST;
 176               else
 177                 {
 178                   lex_error (NULL);
 179                   goto error;
 180                 }
 181
 182               if (dls->type != -1)
 183                 {
 184                   msg (SE, _("Only one of FIXED, FREE, or LIST may "
 185                              "be specified."));
 186                   goto error;
 187                 }
 188               dls->type = type;
 189
 190               if ((dls->type == DLS_FREE || dls->type == DLS_LIST)
 191                   && lex_match ('('))
 192                 {
 193                   while (!lex_match (')'))
 194                     {
 195                       int delim;
 196
 197                       if (lex_match_id ("TAB"))
 198                         delim = '\t';
 199                       else if (token == T_STRING && tokstr.length == 1)
 200                         {
 201                           delim = tokstr.string[0];
 202                           lex_get();
 203                         }
 204                       else
 205                         {
 206                           lex_error (NULL);
 207                           goto error;
 208                         }
 209
 210                       dls->delims = xrealloc (dls->delims, dls->delim_cnt + 1);
 211                       dls->delims[dls->delim_cnt++] = delim;
 212
 213                       lex_match (',');
 214                     }
 215                 }
 216             }
 217         }
 218       else
 219         {
 220           lex_error (NULL);
 221           goto error;
 222         }
 223     }
 224
 225   dls->case_size = dict_get_case_size (default_dict);
 226   fh_set_default_handle (fh);
 227
 228   if (dls->type == -1)
 229     dls->type = DLS_FIXED;
 230
 231   if (table == -1)
 232     {
 233       if (dls->type == DLS_FREE)
 234         table = 0;
 235       else
 236         table = 1;
 237     }
 238
 239   if (dls->type == DLS_FIXED)
 240     {
 241       if (!parse_fixed (dls))
 242         goto error;
 243       if (table)
 244         dump_fixed_table (dls->first, fh, dls->rec_cnt);
 245     }
 246   else
 247     {
 248       if (!parse_free (&dls->first, &dls->last))
 249         goto error;
 250       if (table)
 251         dump_free_table (dls, fh);
 252     }
 253
 254   dls->reader = dfm_open_reader (fh);
 255   if (dls->reader == NULL)
 256     goto error;
 257
 258   if (vfm_source != NULL)
 259     add_transformation (data_list_trns_proc, data_list_trns_free, dls);
 260   else
 261     vfm_source = create_case_source (&data_list_source_class, dls);
 262
 263   return CMD_SUCCESS;
 264
 265  error:
 266   data_list_trns_free (dls);
 267   return CMD_CASCADING_FAILURE;
 268 }
 269
 270 /* Adds SPEC to the linked list with head at FIRST and tail at
 271    LAST. */
 272 static void
 273 append_var_spec (struct dls_var_spec **first, struct dls_var_spec **last,
 274                  struct dls_var_spec *spec)
 275 {
 276   spec->next = NULL;
 277
 278   if (*first == NULL)
 279     *first = spec;
 280   else
 281     (*last)->next = spec;
 282   *last = spec;
 283 }
 284 \f
 285 /* Fixed-format parsing. */
 286
 287 /* Used for chaining together fortran-like format specifiers. */
 288 struct fmt_list
 289   {
 290     struct fmt_list *next;
 291     int count;
 292     struct fmt_spec f;
 293     struct fmt_list *down;
 294   };
 295
 296 /* State of parsing DATA LIST. */
 297 struct fixed_parsing_state
 298   {
 299     char **name;                /* Variable names. */
 300     size_t name_cnt;            /* Number of names. */
 301
 302     int recno;                  /* Index of current record. */
 303     int sc;                     /* 1-based column number of starting column for
 304                                    next field to output. */
 305   };
 306
 307 static int fixed_parse_compatible (struct fixed_parsing_state *,
 308                                    struct dls_var_spec **,
 309                                    struct dls_var_spec **);
 310 static int fixed_parse_fortran (struct fixed_parsing_state *,
 311                                 struct dls_var_spec **,
 312                                 struct dls_var_spec **);
 313
 314 /* Parses all the variable specifications for DATA LIST FIXED,
 315    storing them into DLS.  Returns nonzero if successful. */
 316 static int
 317 parse_fixed (struct data_list_pgm *dls)
 318 {
 319   struct fixed_parsing_state fx;
 320   size_t i;
 321
 322   fx.recno = 0;
 323   fx.sc = 1;
 324
 325   while (token != '.')
 326     {
 327       while (lex_match ('/'))
 328         {
 329           fx.recno++;
 330           if (lex_is_integer ())
 331             {
 332               if (lex_integer () < fx.recno)
 333                 {
 334                   msg (SE, _("The record number specified, %ld, is "
 335                              "before the previous record, %d.  Data "
 336                              "fields must be listed in order of "
 337                              "increasing record number."),
 338                        lex_integer (), fx.recno - 1);
 339                   return 0;
 340                 }
 341
 342               fx.recno = lex_integer ();
 343               lex_get ();
 344             }
 345           fx.sc = 1;
 346         }
 347
 348       if (!parse_DATA_LIST_vars (&fx.name, &fx.name_cnt, PV_NONE))
 349         return 0;
 350
 351       if (lex_is_number ())
 352         {
 353           if (!fixed_parse_compatible (&fx, &dls->first, &dls->last))
 354             goto fail;
 355         }
 356       else if (token == '(')
 357         {
 358           if (!fixed_parse_fortran (&fx, &dls->first, &dls->last))
 359             goto fail;
 360         }
 361       else
 362         {
 363           msg (SE, _("SPSS-like or FORTRAN-like format "
 364                      "specification expected after variable names."));
 365           goto fail;
 366         }
 367
 368       for (i = 0; i < fx.name_cnt; i++)
 369         free (fx.name[i]);
 370       free (fx.name);
 371     }
 372   if (dls->first == NULL)
 373     {
 374       msg (SE, _("At least one variable must be specified."));
 375       return 0;
 376     }
 377   if (dls->rec_cnt && dls->last->rec > dls->rec_cnt)
 378     {
 379       msg (SE, _("Variables are specified on records that "
 380                  "should not exist according to RECORDS subcommand."));
 381       return 0;
 382     }
 383   else if (!dls->rec_cnt)
 384     dls->rec_cnt = dls->last->rec;
 385   return lex_end_of_command () == CMD_SUCCESS;
 386
 387 fail:
 388   for (i = 0; i < fx.name_cnt; i++)
 389     free (fx.name[i]);
 390   free (fx.name);
 391   return 0;
 392 }
 393
 394 /* Parses a variable specification in the form 1-10 (A) based on
 395    FX and adds specifications to the linked list with head at
 396    FIRST and tail at LAST. */
 397 static int
 398 fixed_parse_compatible (struct fixed_parsing_state *fx,
 399                         struct dls_var_spec **first, struct dls_var_spec **last)
 400 {
 401   struct fmt_spec input;
 402   int fc, lc;
 403   int width;
 404   int i;
 405
 406   /* First column. */
 407   if (!lex_force_int ())
 408     return 0;
 409   fc = lex_integer ();
 410   if (fc < 1)
 411     {
 412       msg (SE, _("Column positions for fields must be positive."));
 413       return 0;
 414     }
 415   lex_get ();
 416
 417   /* Last column. */
 418   lex_negative_to_dash ();
 419   if (lex_match ('-'))
 420     {
 421       if (!lex_force_int ())
 422         return 0;
 423       lc = lex_integer ();
 424       if (lc < 1)
 425         {
 426           msg (SE, _("Column positions for fields must be positive."));
 427           return 0;
 428         }
 429       else if (lc < fc)
 430         {
 431           msg (SE, _("The ending column for a field must be "
 432                      "greater than the starting column."));
 433           return 0;
 434         }
 435
 436       lex_get ();
 437     }
 438   else
 439     lc = fc;
 440
 441   /* Divide columns evenly. */
 442   input.w = (lc - fc + 1) / fx->name_cnt;
 443   if ((lc - fc + 1) % fx->name_cnt)
 444     {
 445       msg (SE, _("The %d columns %d-%d "
 446                  "can't be evenly divided into %d fields."),
 447            lc - fc + 1, fc, lc, fx->name_cnt);
 448       return 0;
 449     }
 450
 451   /* Format specifier. */
 452   if (lex_match ('('))
 453     {
 454       struct fmt_desc *fdp;
 455
 456       if (token == T_ID)
 457         {
 458           const char *cp;
 459
 460           input.type = parse_format_specifier_name (&cp, 0);
 461           if (input.type == -1)
 462             return 0;
 463           if (*cp)
 464             {
 465               msg (SE, _("A format specifier on this line "
 466                          "has extra characters on the end."));
 467               return 0;
 468             }
 469
 470           lex_get ();
 471           lex_match (',');
 472         }
 473       else
 474         input.type = FMT_F;
 475
 476       if (lex_is_integer ())
 477         {
 478           if (lex_integer () < 1)
 479             {
 480               msg (SE, _("The value for number of decimal places "
 481                          "must be at least 1."));
 482               return 0;
 483             }
 484
 485           input.d = lex_integer ();
 486           lex_get ();
 487         }
 488       else
 489         input.d = 0;
 490
 491       fdp = &formats[input.type];
 492       if (fdp->n_args < 2 && input.d)
 493         {
 494           msg (SE, _("Input format %s doesn't accept decimal places."),
 495                fdp->name);
 496           return 0;
 497         }
 498
 499       if (input.d > 16)
 500         input.d = 16;
 501
 502       if (!lex_force_match (')'))
 503         return 0;
 504     }
 505   else
 506     {
 507       input.type = FMT_F;
 508       input.d = 0;
 509     }
 510   if (!check_input_specifier (&input, 1))
 511     return 0;
 512
 513   /* Start column for next specification. */
 514   fx->sc = lc + 1;
 515
 516   /* Width of variables to create. */
 517   if (input.type == FMT_A || input.type == FMT_AHEX)
 518     width = input.w;
 519   else
 520     width = 0;
 521
 522   /* Create variables and var specs. */
 523   for (i = 0; i < fx->name_cnt; i++)
 524     {
 525       struct dls_var_spec *spec;
 526       struct variable *v;
 527
 528       v = dict_create_var (default_dict, fx->name[i], width);
 529       if (v != NULL)
 530         {
 531           convert_fmt_ItoO (&input, &v->print);
 532           v->write = v->print;
 533         }
 534       else
 535         {
 536           v = dict_lookup_var_assert (default_dict, fx->name[i]);
 537           if (vfm_source == NULL)
 538             {
 539               msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 540               return 0;
 541             }
 542           if ((width != 0) != (v->width != 0))
 543             {
 544               msg (SE, _("There is already a variable %s of a "
 545                          "different type."),
 546                    fx->name[i]);
 547               return 0;
 548             }
 549           if (width != 0 && width != v->width)
 550             {
 551               msg (SE, _("There is already a string variable %s of a "
 552                          "different width."), fx->name[i]);
 553               return 0;
 554             }
 555         }
 556
 557       spec = xmalloc (sizeof *spec);
 558       spec->input = input;
 559       spec->v = v;
 560       spec->fv = v->fv;
 561       spec->rec = fx->recno;
 562       spec->fc = fc + input.w * i;
 563       spec->lc = spec->fc + input.w - 1;
 564       append_var_spec (first, last, spec);
 565     }
 566   return 1;
 567 }
 568
 569 /* Destroy format list F and, if RECURSE is nonzero, all its
 570    sublists. */
 571 static void
 572 destroy_fmt_list (struct fmt_list *f, int recurse)
 573 {
 574   struct fmt_list *next;
 575
 576   for (; f; f = next)
 577     {
 578       next = f->next;
 579       if (recurse && f->f.type == FMT_DESCEND)
 580         destroy_fmt_list (f->down, 1);
 581       free (f);
 582     }
 583 }
 584
 585 /* Takes a hierarchically structured fmt_list F as constructed by
 586    fixed_parse_fortran(), and flattens it, adding the variable
 587    specifications to the linked list with head FIRST and tail
 588    LAST.  NAME_IDX is used to take values from the list of names
 589    in FX; it should initially point to a value of 0. */
 590 static int
 591 dump_fmt_list (struct fixed_parsing_state *fx, struct fmt_list *f,
 592                struct dls_var_spec **first, struct dls_var_spec **last,
 593                int *name_idx)
 594 {
 595   int i;
 596
 597   for (; f; f = f->next)
 598     if (f->f.type == FMT_X)
 599       fx->sc += f->count;
 600     else if (f->f.type == FMT_T)
 601       fx->sc = f->f.w;
 602     else if (f->f.type == FMT_NEWREC)
 603       {
 604         fx->recno += f->count;
 605         fx->sc = 1;
 606       }
 607     else
 608       for (i = 0; i < f->count; i++)
 609         if (f->f.type == FMT_DESCEND)
 610           {
 611             if (!dump_fmt_list (fx, f->down, first, last, name_idx))
 612               return 0;
 613           }
 614         else
 615           {
 616             struct dls_var_spec *spec;
 617             int width;
 618             struct variable *v;
 619
 620             if (formats[f->f.type].cat & FCAT_STRING)
 621               width = f->f.w;
 622             else
 623               width = 0;
 624             if (*name_idx >= fx->name_cnt)
 625               {
 626                 msg (SE, _("The number of format "
 627                            "specifications exceeds the given number of "
 628                            "variable names."));
 629                 return 0;
 630               }
 631
 632             v = dict_create_var (default_dict, fx->name[(*name_idx)++], width);
 633             if (!v)
 634               {
 635                 msg (SE, _("%s is a duplicate variable name."), fx->name[i]);
 636                 return 0;
 637               }
 638
 639             spec = xmalloc (sizeof *spec);
 640             spec->v = v;
 641             spec->input = f->f;
 642             spec->fv = v->fv;
 643             spec->rec = fx->recno;
 644             spec->fc = fx->sc;
 645             spec->lc = fx->sc + f->f.w - 1;
 646             append_var_spec (first, last, spec);
 647
 648             convert_fmt_ItoO (&spec->input, &v->print);
 649             v->write = v->print;
 650
 651             fx->sc += f->f.w;
 652           }
 653   return 1;
 654 }
 655
 656 /* Recursively parses a FORTRAN-like format specification into
 657    the linked list with head FIRST and tail TAIL.  LEVEL is the
 658    level of recursion, starting from 0.  Returns the parsed
 659    specification if successful, or a null pointer on failure.  */
 660 static struct fmt_list *
 661 fixed_parse_fortran_internal (struct fixed_parsing_state *fx,
 662                               struct dls_var_spec **first,
 663                               struct dls_var_spec **last)
 664 {
 665   struct fmt_list *head = NULL;
 666   struct fmt_list *tail = NULL;
 667
 668   lex_force_match ('(');
 669   while (token != ')')
 670     {
 671       /* New fmt_list. */
 672       struct fmt_list *new = xmalloc (sizeof *new);
 673       new->next = NULL;
 674
 675       /* Append new to list. */
 676       if (head != NULL)
 677         tail->next = new;
 678       else
 679         head = new;
 680       tail = new;
 681
 682       /* Parse count. */
 683       if (lex_is_integer ())
 684         {
 685           new->count = lex_integer ();
 686           lex_get ();
 687         }
 688       else
 689         new->count = 1;
 690
 691       /* Parse format specifier. */
 692       if (token == '(')
 693         {
 694           new->f.type = FMT_DESCEND;
 695           new->down = fixed_parse_fortran_internal (fx, first, last);
 696           if (new->down == NULL)
 697             goto fail;
 698         }
 699       else if (lex_match ('/'))
 700         new->f.type = FMT_NEWREC;
 701       else if (!parse_format_specifier (&new->f, FMTP_ALLOW_XT)
 702                || !check_input_specifier (&new->f, 1))
 703         goto fail;
 704
 705       lex_match (',');
 706     }
 707   lex_force_match (')');
 708
 709   return head;
 710
 711 fail:
 712   destroy_fmt_list (head, 0);
 713
 714   return NULL;
 715 }
 716
 717 /* Parses a FORTRAN-like format specification into the linked
 718    list with head FIRST and tail LAST.  Returns nonzero if
 719    successful. */
 720 static int
 721 fixed_parse_fortran (struct fixed_parsing_state *fx,
 722                      struct dls_var_spec **first, struct dls_var_spec **last)
 723 {
 724   struct fmt_list *list;
 725   int name_idx;
 726
 727   list = fixed_parse_fortran_internal (fx, first, last);
 728   if (list == NULL)
 729     return 0;
 730
 731   name_idx = 0;
 732   dump_fmt_list (fx, list, first, last, &name_idx);
 733   destroy_fmt_list (list, 1);
 734   if (name_idx < fx->name_cnt)
 735     {
 736       msg (SE, _("There aren't enough format specifications "
 737                  "to match the number of variable names given."));
 738       return 0;
 739     }
 740
 741   return 1;
 742 }
 743
 744 /* Displays a table giving information on fixed-format variable
 745    parsing on DATA LIST. */
 746 /* FIXME: The `Columns' column should be divided into three columns,
 747    one for the starting column, one for the dash, one for the ending
 748    column; then right-justify the starting column and left-justify the
 749    ending column. */
 750 static void
 751 dump_fixed_table (const struct dls_var_spec *specs,
 752                   const struct file_handle *fh, int rec_cnt)
 753 {
 754   const struct dls_var_spec *spec;
 755   struct tab_table *t;
 756   int i;
 757
 758   for (i = 0, spec = specs; spec; spec = spec->next)
 759     i++;
 760   t = tab_create (4, i + 1, 0);
 761   tab_columns (t, TAB_COL_DOWN, 1);
 762   tab_headers (t, 0, 0, 1, 0);
 763   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 764   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Record"));
 765   tab_text (t, 2, 0, TAB_CENTER | TAT_TITLE, _("Columns"));
 766   tab_text (t, 3, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 767   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 3, i);
 768   tab_hline (t, TAL_2, 0, 3, 1);
 769   tab_dim (t, tab_natural_dimensions);
 770
 771   for (i = 1, spec = specs; spec; spec = spec->next, i++)
 772     {
 773       tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 774       tab_text (t, 1, i, TAT_PRINTF, "%d", spec->rec);
 775       tab_text (t, 2, i, TAT_PRINTF, "%3d-%3d",
 776                     spec->fc, spec->lc);
 777       tab_text (t, 3, i, TAB_LEFT | TAB_FIX,
 778                     fmt_to_string (&spec->input));
 779     }
 780
 781   tab_title (t, ngettext ("Reading %d record from %s.",
 782                           "Reading %d records from %s.", rec_cnt),
 783              rec_cnt, fh_get_name (fh));
 784   tab_submit (t);
 785 }
 786 \f
 787 /* Free-format parsing. */
 788
 789 /* Parses variable specifications for DATA LIST FREE and adds
 790    them to the linked list with head FIRST and tail LAST.
 791    Returns nonzero only if successful. */
 792 static int
 793 parse_free (struct dls_var_spec **first, struct dls_var_spec **last)
 794 {
 795   lex_get ();
 796   while (token != '.')
 797     {
 798       struct fmt_spec input, output;
 799       char **name;
 800       size_t name_cnt;
 801       int width;
 802       size_t i;
 803
 804       if (!parse_DATA_LIST_vars (&name, &name_cnt, PV_NONE))
 805         return 0;
 806
 807       if (lex_match ('('))
 808         {
 809           if (!parse_format_specifier (&input, 0)
 810               || !check_input_specifier (&input, 1)
 811               || !lex_force_match (')'))
 812             {
 813               for (i = 0; i < name_cnt; i++)
 814                 free (name[i]);
 815               free (name);
 816               return 0;
 817             }
 818           convert_fmt_ItoO (&input, &output);
 819         }
 820       else
 821         {
 822           lex_match ('*');
 823           input = make_input_format (FMT_F, 8, 0);
 824           output = *get_format ();
 825         }
 826
 827       if (input.type == FMT_A || input.type == FMT_AHEX)
 828         width = input.w;
 829       else
 830         width = 0;
 831       for (i = 0; i < name_cnt; i++)
 832         {
 833           struct dls_var_spec *spec;
 834           struct variable *v;
 835
 836           v = dict_create_var (default_dict, name[i], width);
 837
 838           if (!v)
 839             {
 840               msg (SE, _("%s is a duplicate variable name."), name[i]);
 841               return 0;
 842             }
 843           v->print = v->write = output;
 844
 845           spec = xmalloc (sizeof *spec);
 846           spec->input = input;
 847           spec->v = v;
 848           spec->fv = v->fv;
 849           str_copy_trunc (spec->name, sizeof spec->name, v->name);
 850           append_var_spec (first, last, spec);
 851         }
 852       for (i = 0; i < name_cnt; i++)
 853         free (name[i]);
 854       free (name);
 855     }
 856
 857   return lex_end_of_command () == CMD_SUCCESS;
 858 }
 859
 860 /* Displays a table giving information on free-format variable parsing
 861    on DATA LIST. */
 862 static void
 863 dump_free_table (const struct data_list_pgm *dls,
 864                  const struct file_handle *fh)
 865 {
 866   struct tab_table *t;
 867   int i;
 868
 869   {
 870     struct dls_var_spec *spec;
 871     for (i = 0, spec = dls->first; spec; spec = spec->next)
 872       i++;
 873   }
 874
 875   t = tab_create (2, i + 1, 0);
 876   tab_columns (t, TAB_COL_DOWN, 1);
 877   tab_headers (t, 0, 0, 1, 0);
 878   tab_text (t, 0, 0, TAB_CENTER | TAT_TITLE, _("Variable"));
 879   tab_text (t, 1, 0, TAB_CENTER | TAT_TITLE, _("Format"));
 880   tab_box (t, TAL_1, TAL_1, TAL_0, TAL_1, 0, 0, 1, i);
 881   tab_hline (t, TAL_2, 0, 1, 1);
 882   tab_dim (t, tab_natural_dimensions);
 883
 884   {
 885     struct dls_var_spec *spec;
 886
 887     for (i = 1, spec = dls->first; spec; spec = spec->next, i++)
 888       {
 889         tab_text (t, 0, i, TAB_LEFT, spec->v->name);
 890         tab_text (t, 1, i, TAB_LEFT | TAB_FIX, fmt_to_string (&spec->input));
 891       }
 892   }
 893
 894   tab_title (t, _("Reading free-form data from %s."), fh_get_name (fh));
 895
 896   tab_submit (t);
 897 }
 898 \f
 899 /* Input procedure. */
 900
 901 /* Extracts a field from the current position in the current
 902    record.  Fields can be unquoted or quoted with single- or
 903    double-quote characters.  *FIELD is set to the field content.
 904    After parsing the field, sets the current position in the
 905    record to just past the field and any trailing delimiter.
 906    END_BLANK is used internally; it should be initialized by the
 907    caller to 0 and left alone afterward.  Returns 0 on failure or
 908    a 1-based column number indicating the beginning of the field
 909    on success. */
 910 static int
 911 cut_field (const struct data_list_pgm *dls, struct fixed_string *field,
 912            int *end_blank)
 913 {
 914   struct fixed_string line;
 915   char *cp;
 916   size_t column_start;
 917
 918   if (dfm_eof (dls->reader))
 919     return 0;
 920   if (dls->delim_cnt == 0)
 921     dfm_expand_tabs (dls->reader);
 922   dfm_get_record (dls->reader, &line);
 923
 924   cp = ls_c_str (&line);
 925   if (dls->delim_cnt == 0)
 926     {
 927       /* Skip leading whitespace. */
 928       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 929         cp++;
 930       if (cp >= ls_end (&line))
 931         return 0;
 932
 933       /* Handle actual data, whether quoted or unquoted. */
 934       if (*cp == '\'' || *cp == '"')
 935         {
 936           int quote = *cp;
 937
 938           field->string = ++cp;
 939           while (cp < ls_end (&line) && *cp != quote)
 940             cp++;
 941           field->length = cp - field->string;
 942           if (cp < ls_end (&line))
 943             cp++;
 944           else
 945             msg (SW, _("Quoted string missing terminating `%c'."), quote);
 946         }
 947       else
 948         {
 949           field->string = cp;
 950           while (cp < ls_end (&line)
 951                  && !isspace ((unsigned char) *cp) && *cp != ',')
 952             cp++;
 953           field->length = cp - field->string;
 954         }
 955
 956       /* Skip trailing whitespace and a single comma if present. */
 957       while (cp < ls_end (&line) && isspace ((unsigned char) *cp))
 958         cp++;
 959       if (cp < ls_end (&line) && *cp == ',')
 960         cp++;
 961     }
 962   else
 963     {
 964       if (cp >= ls_end (&line))
 965         {
 966           int column = dfm_column_start (dls->reader);
 967                /* A blank line or a line that ends in \t has a
 968              trailing blank field. */
 969           if (column == 1 || (column > 1 && cp[-1] == '\t'))
 970             {
 971               if (*end_blank == 0)
 972                 {
 973                   *end_blank = 1;
 974                   field->string = ls_end (&line);
 975                   field->length = 0;
 976                   dfm_forward_record (dls->reader);
 977                   return column;
 978                 }
 979               else
 980                 {
 981                   *end_blank = 0;
 982                   return 0;
 983                 }
 984             }
 985           else
 986             return 0;
 987         }
 988       else
 989         {
 990           field->string = cp;
 991           while (cp < ls_end (&line)
 992                  && memchr (dls->delims, *cp, dls->delim_cnt) == NULL)
 993             cp++;
 994           field->length = cp - field->string;
 995           if (cp < ls_end (&line))
 996             cp++;
 997         }
 998     }
 999
1000   dfm_forward_columns (dls->reader, field->string - line.string);
1001   column_start = dfm_column_start (dls->reader);
1002
1003   dfm_forward_columns (dls->reader, cp - field->string);
1004
1005   return column_start;
1006 }
1007
1008 static bool read_from_data_list_fixed (const struct data_list_pgm *,
1009                                        struct ccase *);
1010 static bool read_from_data_list_free (const struct data_list_pgm *,
1011                                       struct ccase *);
1012 static bool read_from_data_list_list (const struct data_list_pgm *,
1013                                       struct ccase *);
1014
1015 /* Reads a case from DLS into C.
1016    Returns true if successful, false at end of file or on I/O error. */
1017 static bool
1018 read_from_data_list (const struct data_list_pgm *dls, struct ccase *c)
1019 {
1020   bool retval;
1021
1022   dfm_push (dls->reader);
1023   switch (dls->type)
1024     {
1025     case DLS_FIXED:
1026       retval = read_from_data_list_fixed (dls, c);
1027       break;
1028     case DLS_FREE:
1029       retval = read_from_data_list_free (dls, c);
1030       break;
1031     case DLS_LIST:
1032       retval = read_from_data_list_list (dls, c);
1033       break;
1034     default:
1035       abort ();
1036     }
1037   dfm_pop (dls->reader);
1038
1039   return retval;
1040 }
1041
1042 /* Reads a case from the data file into C, parsing it according
1043    to fixed-format syntax rules in DLS.
1044    Returns true if successful, false at end of file or on I/O error. */
1045 static bool
1046 read_from_data_list_fixed (const struct data_list_pgm *dls, struct ccase *c)
1047 {
1048   struct dls_var_spec *var_spec = dls->first;
1049   int i;
1050
1051   if (dfm_eof (dls->reader))
1052     return false;
1053   for (i = 1; i <= dls->rec_cnt; i++)
1054     {
1055       struct fixed_string line;
1056
1057       if (dfm_eof (dls->reader))
1058         {
1059           /* Note that this can't occur on the first record. */
1060           msg (SW, _("Partial case of %d of %d records discarded."),
1061                i - 1, dls->rec_cnt);
1062           return false;
1063         }
1064       dfm_expand_tabs (dls->reader);
1065       dfm_get_record (dls->reader, &line);
1066
1067       for (; var_spec && i == var_spec->rec; var_spec = var_spec->next)
1068         {
1069           struct data_in di;
1070
1071           data_in_finite_line (&di, ls_c_str (&line), ls_length (&line),
1072                                var_spec->fc, var_spec->lc);
1073           di.v = case_data_rw (c, var_spec->fv);
1074           di.flags = DI_IMPLIED_DECIMALS;
1075           di.f1 = var_spec->fc;
1076           di.format = var_spec->input;
1077
1078           data_in (&di);
1079         }
1080
1081       dfm_forward_record (dls->reader);
1082     }
1083
1084   return true;
1085 }
1086
1087 /* Reads a case from the data file into C, parsing it according
1088    to free-format syntax rules in DLS.
1089    Returns true if successful, false at end of file or on I/O error. */
1090 static bool
1091 read_from_data_list_free (const struct data_list_pgm *dls, struct ccase *c)
1092 {
1093   struct dls_var_spec *var_spec;
1094   int end_blank = 0;
1095
1096   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1097     {
1098       struct fixed_string field;
1099       int column;
1100
1101       /* Cut out a field and read in a new record if necessary. */
1102       for (;;)
1103         {
1104           column = cut_field (dls, &field, &end_blank);
1105           if (column != 0)
1106             break;
1107
1108           if (!dfm_eof (dls->reader))
1109             dfm_forward_record (dls->reader);
1110           if (dfm_eof (dls->reader))
1111             {
1112               if (var_spec != dls->first)
1113                 msg (SW, _("Partial case discarded.  The first variable "
1114                            "missing was %s."), var_spec->name);
1115               return false;
1116             }
1117         }
1118
1119       {
1120         struct data_in di;
1121
1122         di.s = ls_c_str (&field);
1123         di.e = ls_end (&field);
1124         di.v = case_data_rw (c, var_spec->fv);
1125         di.flags = 0;
1126         di.f1 = column;
1127         di.format = var_spec->input;
1128         data_in (&di);
1129       }
1130     }
1131   return true;
1132 }
1133
1134 /* Reads a case from the data file and parses it according to
1135    list-format syntax rules.
1136    Returns true if successful, false at end of file or on I/O error. */
1137 static bool
1138 read_from_data_list_list (const struct data_list_pgm *dls, struct ccase *c)
1139 {
1140   struct dls_var_spec *var_spec;
1141   int end_blank = 0;
1142
1143   if (dfm_eof (dls->reader))
1144     return false;
1145
1146   for (var_spec = dls->first; var_spec; var_spec = var_spec->next)
1147     {
1148       struct fixed_string field;
1149       int column;
1150
1151       /* Cut out a field and check for end-of-line. */
1152       column = cut_field (dls, &field, &end_blank);
1153       if (column == 0)
1154         {
1155           if (get_undefined ())
1156             msg (SW, _("Missing value(s) for all variables from %s onward.  "
1157                        "These will be filled with the system-missing value "
1158                        "or blanks, as appropriate."),
1159                  var_spec->name);
1160           for (; var_spec; var_spec = var_spec->next)
1161             {
1162               int width = get_format_var_width (&var_spec->input);
1163               if (width == 0)
1164                 case_data_rw (c, var_spec->fv)->f = SYSMIS;
1165               else
1166                 memset (case_data_rw (c, var_spec->fv)->s, ' ', width);
1167             }
1168           break;
1169         }
1170
1171       {
1172         struct data_in di;
1173
1174         di.s = ls_c_str (&field);
1175         di.e = ls_end (&field);
1176         di.v = case_data_rw (c, var_spec->fv);
1177         di.flags = 0;
1178         di.f1 = column;
1179         di.format = var_spec->input;
1180         data_in (&di);
1181       }
1182     }
1183
1184   dfm_forward_record (dls->reader);
1185   return true;
1186 }
1187
1188 /* Destroys SPEC. */
1189 static void
1190 destroy_dls_var_spec (struct dls_var_spec *spec)
1191 {
1192   struct dls_var_spec *next;
1193
1194   while (spec != NULL)
1195     {
1196       next = spec->next;
1197       free (spec);
1198       spec = next;
1199     }
1200 }
1201
1202 /* Destroys DATA LIST transformation DLS.
1203    Returns true if successful, false if an I/O error occurred. */
1204 static bool
1205 data_list_trns_free (void *dls_)
1206 {
1207   struct data_list_pgm *dls = dls_;
1208   free (dls->delims);
1209   destroy_dls_var_spec (dls->first);
1210   dfm_close_reader (dls->reader);
1211   free (dls);
1212   return true;
1213 }
1214
1215 /* Handle DATA LIST transformation DLS, parsing data into C. */
1216 static int
1217 data_list_trns_proc (void *dls_, struct ccase *c, int case_num UNUSED)
1218 {
1219   struct data_list_pgm *dls = dls_;
1220   int retval;
1221
1222   if (read_from_data_list (dls, c))
1223     retval = TRNS_CONTINUE;
1224   else if (dfm_reader_error (dls->reader) || dfm_eof (dls->reader) > 1)
1225     {
1226       /* An I/O error, or encountering end of file for a second
1227          time, should be escalated into a more serious error. */
1228       retval = TRNS_ERROR;
1229     }
1230   else
1231     retval = TRNS_DROP_CASE;
1232
1233   /* If there was an END subcommand handle it. */
1234   if (dls->end != NULL)
1235     {
1236       double *end = &case_data_rw (c, dls->end->fv)->f;
1237       if (retval == TRNS_DROP_CASE)
1238         {
1239           *end = 1.0;
1240           retval = TRNS_CONTINUE;
1241         }
1242       else
1243         *end = 0.0;
1244     }
1245
1246   return retval;
1247 }
1248 \f
1249 /* Reads all the records from the data file and passes them to
1250    write_case().
1251    Returns true if successful, false if an I/O error occurred. */
1252 static bool
1253 data_list_source_read (struct case_source *source,
1254                        struct ccase *c,
1255                        write_case_func *write_case, write_case_data wc_data)
1256 {
1257   struct data_list_pgm *dls = source->aux;
1258
1259   for (;;)
1260     {
1261       bool ok;
1262
1263       if (!read_from_data_list (dls, c))
1264         return !dfm_reader_error (dls->reader);
1265
1266       dfm_push (dls->reader);
1267       ok = write_case (wc_data);
1268       dfm_pop (dls->reader);
1269       if (!ok)
1270         return false;
1271     }
1272 }
1273
1274 /* Destroys the source's internal data. */
1275 static void
1276 data_list_source_destroy (struct case_source *source)
1277 {
1278   data_list_trns_free (source->aux);
1279 }
1280
1281 static const struct case_source_class data_list_source_class =
1282   {
1283     "DATA LIST",
1284     NULL,
1285     data_list_source_read,
1286     data_list_source_destroy,
1287   };