From mboxrd@z Thu Jan 1 00:00:00 1970 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.4 X-Google-Language: ENGLISH,ASCII-7-bit X-Google-Thread: 103376,7fc767abbf17c947 X-Google-Attributes: gid103376,public From: mfb@mbunix.mitre.org (Michael F Brenner) Subject: Re: Parsing a line into strings Date: 1998/07/09 Message-ID: <6o2jjm$e9@top.mitre.org> X-Deja-AN: 369874419 References: <35A3A199.D55C3153@oit.edu> <6o14rm$3nv@drn.newsguy.com> Organization: The MITRE Corporation, Bedford Mass. Newsgroups: comp.lang.ada Date: 1998-07-09T00:00:00+00:00 List-Id: 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; -------------------------------------------------------