Re: Parsing a line into strings

[mfb@mbunix.mitre.org (Michael F Brenner)]

Some code was posted to this list last year which might do some of the
functionality you wish (depending on what that functionality is).

EXTRACT FROM THIS NEWSGROUP FROM LAST YEAR:
----------------------------------------------------------------------

package fielder is
  pragma pure (fielder);

  -- Sets left_field and right_field to the column pointers dividing
  -- BUFFER into fields.
  --
  -- The field boundaries are any noticed characters (currently eoln & blank)
  -- Computes the number_of_fields. Field zero means the entire buffer
  -- (all fields).
  --
  -- Suggested usage:
  --
  -- procedure try_fielder is
  --   fielding:       fieldings;
  --   message:        string (1..80);
  --   message_length: natural := 49; -- the characters used in MESSAGE
  -- begin
  --   break_into_fields (message, message_length, fielding);
  --   print ("field (1)=" &
  --          message (fielding.left_field(1) .. fielding.right_field(1));
  -- end try_fielder;
  --
type field_lists  is array (0..255) of natural;

  type fieldings is record
    left_field, right_field: field_lists;
    number_of_fields:        natural;
  end record;

  procedure break_into_fields (buffer:          string;
                               length:          natural;
                               fielding: in out fieldings;
                               blank1:          character := ' ';
                               blank2:          character := ascii.ht);

                               -- After break_into_fields, fielding contains
                               -- the left and right boundaries of each
                               -- of the fields. Used for efficient access
                               -- to those boundaries in the long form of
                               -- field.

  function field              (field_no:        natural;
                               buffer:          string;
                               length:          natural;
                               fielding:        fieldings) return string;

                               -- The long form of FIELD returns the
                               -- desired field as broken up in FIELDING.
                               -- This breaks is up once and returns
                               -- many fields without breaking it up again.

  function field              (field_no:        natural;
                               buffer:          string) return string;

                               -- The short form of FIELD returns the
                               -- desired field, breaking the buffer up
                               -- into fields each time it is called.
                               -- Good for one-time calls, but bad for loops.

procedure nullify           (field_no:        natural;
                               buffer:   in out string; -- length doesnt change
                               length:   in out natural;
                               fielding: in out fieldings);

                               -- After NULLIFY, the desired field is
                               -- all blanks and fielding reflects that

 procedure set_field (field_no: natural;           -- field to be replaced
                      buffer:   in out string;     -- length doesnt change
                      length:   in out natural;    -- changes
                      fielding: in out fieldings;  -- changes
                      new_data: string);           -- is inserted

end fielder;





package body fielder is

procedure break_into_fields (buffer: string;
                              length: natural;
                              fielding: in out fieldings;
                              blank1:          character := ' ';
                              blank2:          character := ascii.ht) is

   -- After the procedure BREAK_INTO_FIELDS is called, the FIELDING
   -- contains updated LEFT AND RIGHT. LEFT(1) points to the leftmost
   -- character in the first field. FIELD(1) returns the first field.
   -- FIELD(0) returns buffer (1..length). Nullify sets a field to
   -- null, shifting the other arguments down a position, like $2="" in awk.

   end_of_line_character: constant character := character'val (10);

   type bit_lists is array (character) of boolean;
   pragma pack (bit_lists);
   noticed: bit_lists := (others => false);

   column_upto: natural   := buffer'first;
   ch:          character := ' ';
   fielder_len_gt_length: exception;
   last: constant natural := buffer'first - 1 + length;

   procedure get_next_character is
   begin
     if column_upto > last then
       ch := end_of_line_character;
     else
       ch := buffer (column_upto);
     end if;
     column_upto := column_upto + 1;
   end get_next_character;

   procedure find_a_non_blank is
   begin
     loop
       get_next_character;
       exit when not noticed (ch);
       exit when ch = end_of_line_character;
     end loop;
   end find_a_non_blank;

 begin
   noticed (end_of_line_character) := true;
   noticed (blank1) := true;
   noticed (blank2) := true;
   fielding.number_of_fields := 0;
   for j in 1..fielding.left_field'last loop
     fielding.left_field(j)  := 0;
     fielding.right_field(j) := 0;
   end loop; -- Permits user to ask for field 2 when there is only 1 field.
   fielding.left_field (0) := buffer'first;
   fielding.right_field(0) := last;
   if length>buffer'length then
     raise fielder_len_gt_length;
   end if;

   loop
     find_a_non_blank;
     exit when ch = end_of_line_character;
     fielding.number_of_fields := fielding.number_of_fields+1;
     fielding.left_field(fielding.number_of_fields) := column_upto-1;
     if fielding.number_of_fields = field_lists'last then
       fielding.right_field (fielding.number_of_fields) := buffer'last;
       exit;
     end if;
     loop
       get_next_character;
       exit when noticed (ch);
     end loop;
     fielding.right_field(fielding.number_of_fields) := column_upto - 2;
     exit when ch = end_of_line_character;
   end loop;
 end break_into_fields;

 function field (field_no: natural;
                 buffer:   string;
                 length:   natural;
                 fielding: fieldings) return string is

   lf: natural renames fielding.left_field (field_no);
   rf: natural renames fielding.right_field (field_no);
   n:  natural renames fielding.number_of_fields;
 begin
   if field_no = 0 then
     return buffer (1..length);
   elsif length = 0 or else field_no > N or else rf < lf then
     return "";
   else
     declare
       subtype desired_columns is natural range LF .. RF;
       size: constant integer := RF + 1 - LF;
       alternate_buffer: constant string (1..size) := buffer (desired_columns);
     begin
       return alternate_buffer;
     end;
   end if;
 end field;

 function field (field_no: natural;
                 buffer:   string) return string is
   fielding: fieldings;
   aligned_buffer: constant string (1..buffer'length) := buffer;
 begin
   break_into_fields (aligned_buffer, buffer'length, fielding);
   return field (field_no, aligned_buffer, buffer'length, fielding);
 end field;

procedure nullify (field_no: natural;
                    buffer:   in out string;  -- length not changed
                    length:   in out natural;
                    fielding: in out fieldings) is

   -- NULLIFY removes a field, shifting all the other fields left one field.
   -- If the fields were (1=> "AA", 2=> "BC", 3=> "ZZ"), then after giving
   -- NULLIFY (2), the fields are (1=> "AA", 2=> "ZZ"). Nullify(0) nullfies
   -- all fields.

 begin
   if field_no=0 then
     fielding.left_field(0) := 0;
     fielding.right_field(0) := 0;
     fielding.number_of_fields := 0;
     for c in buffer'range loop
       buffer (c) := ' ';
     end loop;
     buffer(buffer'first) := ascii.nul;

       -- All fields will be nullified by the loop below.

   elsif field_no > fielding.number_of_fields then
     null;

     -- Nothing is changed by the loop below.

   elsif fielding.number_of_fields > 0 then
     for c in fielding.left_field(field_no)..
              fielding.right_field(field_no) loop
       buffer(c) := ' ';
     end loop;

     for j in field_no..fielding.number_of_fields - 1 loop
       fielding.left_field(j)  := fielding.left_field(j+1);
       fielding.right_field(j) := fielding.right_field(j+1);
     end loop;
     fielding.number_of_fields := fielding.number_of_fields - 1;

     -- One field is nullified by the loop below;

   end if;

   for j in fielding.number_of_fields+1 ..
            fielding.left_field'last loop
     fielding.left_field(j) := 0;
     fielding.right_field(j) := 0;
   end loop;
   length := fielding.right_field (fielding.number_of_fields);

   -- Unused fields are set to zero length

 end nullify;

 procedure set_field (field_no: natural;           -- field to be replaced
                      buffer:   in out string;     -- length does not change
                      length:   in out natural;    -- changes
                      fielding: in out fieldings;  -- changes
                      new_data: string) is         -- is inserted

   -- The message is broken into three parts: A B C:
   --   @ A contains the fields to the left of field (field_no)
   --   @ B contains the new field (field_no) which MAY CONTAIN BLANKS
   --   @ C contains the fields to the right of field (field_no)

   A: constant string := buffer(1..fielding.left_field(field_no)-1);
   B: string renames new_data;
   C: constant string := buffer(fielding.right_field(field_no)+1..length);
   set_field_too_long: exception;

   procedure set_buffer (message: string) is
   begin
     if message'length > buffer'length then
       raise set_field_too_long;
     end if;
     buffer (1..message'length) := message;
     for i in natural(message'length+1)..buffer'length loop
       buffer (i) := ' ';
     end loop;
     length := message'length;
   end set_buffer;

 begin
   if    A'length=0 and C'length=0 then
     set_buffer (B);
   elsif A'length=0 then
     set_buffer (B & ' ' & C);
   elsif B'length=0 then
     set_buffer (A & ' ' & B);
   else
     set_buffer (A & ' ' & B & ' ' & C);
   end if;
   break_into_fields (buffer, length, fielding);
 end set_field;

end fielder;

with fielder;
procedure ttfield is
  x: constant string      := "    abc def ghi";
  L: natural              := x'length;
  y: string (1..12) := (others => 'A');
  yl: natural := 0;
  tsfield_1: exception;
  tsfield_2: exception;
  use fielder;
  fielding: fieldings;

  procedure assert(condition: boolean) is
    ttfield_failed: exception;
  begin
    if not condition then
      raise ttfield_failed;
    end if;
  end assert;
begin
  break_into_fields (x, L, fielding);
  if fielding.number_of_fields /= 3     or else
     field (1, x, L, fielding) /= "abc" or else
     field (2, x, L, fielding) /= "def" or else
     field (3, x, L, fielding) /= "ghi" then
    raise tsfield_1;
  end if;
  if fielder.key ("a b c", 3, 1) /= "c~a" then
    raise tsfield_2;
  end if;
  fielder.break_into_fields (y, yl, fielding);
  fielder.set_field (0, y, yl, fielding, "");
  assert(yl=0);
  y(1..5):= "a b c";
  yl:=5;
  fielder.break_into_fields (y, yl, fielding);
  assert(yl=5);
  fielder.set_field (0, y, yl, fielding, "");
  assert(yl=0);
end ttfield;
-------------------------------------------------------