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