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