File: dbf\string_tools.adb
1 --::::::::::
2 --stritool.adb
3 --::::::::::
4 -- Developed by (C) Wasiliy W. Molostoff 1994, 1995.
5 -- Moscow, Russia,
6 -- Voice: 7 (095) 398-23-38
7 -- e-mail: edv@edv.msk.ru
8 -- This is free software; you can freely redistribute it and/or
9 -- modify it without any restrictions. Please report any errors.
10 -- All corrections will be made as soon as possible.
11 package body string_tools is
12
13 function build_same_case return translation;
14
15 the_same_case: constant translation := build_same_case;
16
17 procedure format (fmt: string; buf: in out string_object) is
18 use string_handler;
19 mrk, pos, arg: natural;
20
21 begin
22 mrk := fmt'first;
23 loop
24 if mrk > fmt'last
25 then
26 return;
27 end if;
28 pos := mrk;
29 loop
30 exit when fmt (pos) = separator;
31 if pos = fmt'last
32 then
33 append (fmt (mrk..pos), buf);
34 return;
35 end if;
36 pos := pos + 1;
37 end loop;
38 if fmt(pos) = separator
39 then
40 if pos = fmt'last
41 then
42 append (fmt (mrk..pos - 1), buf);
43 return;
44 end if;
45 pos := pos + 1;
46 case fmt (pos) is
47 when '0'..'9' =>
48 append (fmt (mrk..pos - 2), buf);
49 arg := 0;
50 loop
51 arg := 10 * arg + character'pos (fmt (pos))
52 - character'pos ('0');
53 if pos = fmt'last
54 then
55 append (argument (arg), buf);
56 return;
57 end if;
58 pos := pos + 1;
59 exit when not (fmt (pos) in '0'..'9');
60 end loop;
61 append (argument (arg), buf);
62 mrk := pos;
63 when '%' => -- ??? separator =>
64 append (fmt (mrk..pos - 1), buf);
65 if pos = fmt'last
66 then
67 return;
68 end if;
69 mrk := pos + 1;
70 when others =>
71 append (fmt (mrk..pos - 2), buf);
72 mrk := pos;
73 end case;
74 end if;
75 end loop;
76 end format;
77
78 -----------------------------------------------------------------------
79
80 function locate (frag: charset;
81 within: string_object;
82 from: positive := 1;
83 to: positive := positive'last)
84 return natural is
85
86 use string_handler;
87
88 function pos (s: string) return natural;
89 function findit is new translating_mono_in (natural, pos);
90
91 function pos (s: string) return natural is
92 begin
93 if from in s'range then
94 for i in s'range
95 loop
96 if frag (s(i)) then
97 return i;
98 end if;
99 end loop;
100 end if;
101 return 0;
102 end;
103
104 begin
105 return findit (within, from, to);
106 end;
107
108 -----------------------------------------------------------------------
109
110 function spaces return charset is
111 begin
112 return value (ascii.vt & ascii.ht & character'val(32));
113 end;
114
115 -----------------------------------------------------------------------
116
117 -- function value (t: translation) return charset is
118 -- tmp: charset := (others => false);
119 -- begin
120 -- for n in t'range
121 -- loop
122 -- tmp (n) := true;
123 -- end loop;
124 -- return tmp;
125 -- end;
126
127 -----------------------------------------------------------------------
128
129 function numbers return charset is
130 begin
131 return ('0'..'9' => true, others => false);
132 end;
133
134 -----------------------------------------------------------------------
135
136 function lowers return charset is
137 begin
138 return ('a'..'z' => true, others => false);
139 end;
140
141 -----------------------------------------------------------------------
142
143 function uppers return charset is
144 begin
145 return ('A'..'Z' => true, others => false);
146 end;
147
148 -----------------------------------------------------------------------
149
150 function controls return charset is
151 begin
152 return (character'val(0)..character'val(31) => true,
153 others => false);
154 end;
155
156 -----------------------------------------------------------------------
157
158 function specials return charset is
159 begin
160 return value (",:;.!?`'<>{}[]()\/@#$%^&*|~+-");
161 end;
162
163 -----------------------------------------------------------------------
164
165 procedure translate (item: in out string; tab: translation) is
166 begin
167
168 for i in item'range
169 loop
170 item (i) := tab (item (i));
171 end loop;
172
173 end;
174
175 -----------------------------------------------------------------------
176
177 function translate (item: string; tab: translation) return string is
178 tmp : string (item'range);
179 begin
180
181 tmp := item;
182 translate (tmp, tab);
183 return tmp;
184
185 end;
186
187 -----------------------------------------------------------------------
188
189 function upper_case return translation is
190 t: translation := the_same_case;
191 begin
192 t ('a'..'z') := the_same_case ('A'..'Z');
193 return t;
194 end;
195
196 -----------------------------------------------------------------------
197
198 function lower_case return translation is
199 t: translation := the_same_case;
200 begin
201 t ('A'..'Z') := the_same_case ('a'..'z');
202 return t;
203 end;
204
205 -----------------------------------------------------------------------
206
207 function flip_case return translation is
208 t: translation := the_same_case;
209 begin
210 t ('a'..'z') := the_same_case ('A'..'Z');
211 t ('A'..'Z') := the_same_case ('a'..'z');
212 return t;
213 end;
214
215 -----------------------------------------------------------------------
216
217 function same_case return translation is
218 begin
219 return the_same_case;
220 end;
221
222 -----------------------------------------------------------------------
223
224 function build_same_case return translation is
225 t: translation;
226 begin
227 for n in t'range
228 loop
229 t (n) := n;
230 end loop;
231 return t;
232 end;
233
234 end;
235