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