File : a-strfix.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- A D A . S T R I N G S . F I X E D --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- --
19 -- --
20 -- --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 -- Note: This code is derived from the ADAR.CSH public domain Ada 83 versions
33 -- of the Appendix C string handling packages. One change is to avoid the use
34 -- of Is_In, so that we are not dependent on inlining. Note that the search
35 -- function implementations are to be found in the auxiliary package
36 -- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR
37 -- used a subunit for this procedure). The number of errors having to do with
38 -- bounds of function return results were also fixed, and use of & removed for
39 -- efficiency reasons.
40
41 with Ada.Strings.Maps; use Ada.Strings.Maps;
42 with Ada.Strings.Search;
43
44 package body Ada.Strings.Fixed is
45
46 ------------------------
47 -- Search Subprograms --
48 ------------------------
49
50 function Index
51 (Source : String;
52 Pattern : String;
53 Going : Direction := Forward;
54 Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
55 renames Ada.Strings.Search.Index;
56
57 function Index
58 (Source : String;
59 Pattern : String;
60 Going : Direction := Forward;
61 Mapping : Maps.Character_Mapping_Function) return Natural
62 renames Ada.Strings.Search.Index;
63
64 function Index
65 (Source : String;
66 Set : Maps.Character_Set;
67 Test : Membership := Inside;
68 Going : Direction := Forward) return Natural
69 renames Ada.Strings.Search.Index;
70
71 function Index
72 (Source : String;
73 Pattern : String;
74 From : Positive;
75 Going : Direction := Forward;
76 Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
77 renames Ada.Strings.Search.Index;
78
79 function Index
80 (Source : String;
81 Pattern : String;
82 From : Positive;
83 Going : Direction := Forward;
84 Mapping : Maps.Character_Mapping_Function) return Natural
85 renames Ada.Strings.Search.Index;
86
87 function Index
88 (Source : String;
89 Set : Maps.Character_Set;
90 From : Positive;
91 Test : Membership := Inside;
92 Going : Direction := Forward) return Natural
93 renames Ada.Strings.Search.Index;
94
95 function Index_Non_Blank
96 (Source : String;
97 Going : Direction := Forward) return Natural
98 renames Ada.Strings.Search.Index_Non_Blank;
99
100 function Index_Non_Blank
101 (Source : String;
102 From : Positive;
103 Going : Direction := Forward) return Natural
104 renames Ada.Strings.Search.Index_Non_Blank;
105
106 function Count
107 (Source : String;
108 Pattern : String;
109 Mapping : Maps.Character_Mapping := Maps.Identity) return Natural
110 renames Ada.Strings.Search.Count;
111
112 function Count
113 (Source : String;
114 Pattern : String;
115 Mapping : Maps.Character_Mapping_Function) return Natural
116 renames Ada.Strings.Search.Count;
117
118 function Count
119 (Source : String;
120 Set : Maps.Character_Set) return Natural
121 renames Ada.Strings.Search.Count;
122
123 procedure Find_Token
124 (Source : String;
125 Set : Maps.Character_Set;
126 From : Positive;
127 Test : Membership;
128 First : out Positive;
129 Last : out Natural)
130 renames Ada.Strings.Search.Find_Token;
131
132 procedure Find_Token
133 (Source : String;
134 Set : Maps.Character_Set;
135 Test : Membership;
136 First : out Positive;
137 Last : out Natural)
138 renames Ada.Strings.Search.Find_Token;
139
140 ---------
141 -- "*" --
142 ---------
143
144 function "*"
145 (Left : Natural;
146 Right : Character) return String
147 is
148 Result : String (1 .. Left);
149
150 begin
151 for J in Result'Range loop
152 Result (J) := Right;
153 end loop;
154
155 return Result;
156 end "*";
157
158 function "*"
159 (Left : Natural;
160 Right : String) return String
161 is
162 Result : String (1 .. Left * Right'Length);
163 Ptr : Integer := 1;
164
165 begin
166 for J in 1 .. Left loop
167 Result (Ptr .. Ptr + Right'Length - 1) := Right;
168 Ptr := Ptr + Right'Length;
169 end loop;
170
171 return Result;
172 end "*";
173
174 ------------
175 -- Delete --
176 ------------
177
178 function Delete
179 (Source : String;
180 From : Positive;
181 Through : Natural) return String
182 is
183 begin
184 if From > Through then
185 declare
186 subtype Result_Type is String (1 .. Source'Length);
187
188 begin
189 return Result_Type (Source);
190 end;
191
192 elsif From not in Source'Range
193 or else Through > Source'Last
194 then
195 raise Index_Error;
196
197 else
198 declare
199 Front : constant Integer := From - Source'First;
200 Result : String (1 .. Source'Length - (Through - From + 1));
201
202 begin
203 Result (1 .. Front) :=
204 Source (Source'First .. From - 1);
205 Result (Front + 1 .. Result'Last) :=
206 Source (Through + 1 .. Source'Last);
207
208 return Result;
209 end;
210 end if;
211 end Delete;
212
213 procedure Delete
214 (Source : in out String;
215 From : Positive;
216 Through : Natural;
217 Justify : Alignment := Left;
218 Pad : Character := Space)
219 is
220 begin
221 Move (Source => Delete (Source, From, Through),
222 Target => Source,
223 Justify => Justify,
224 Pad => Pad);
225 end Delete;
226
227 ----------
228 -- Head --
229 ----------
230
231 function Head
232 (Source : String;
233 Count : Natural;
234 Pad : Character := Space) return String
235 is
236 subtype Result_Type is String (1 .. Count);
237
238 begin
239 if Count < Source'Length then
240 return
241 Result_Type (Source (Source'First .. Source'First + Count - 1));
242
243 else
244 declare
245 Result : Result_Type;
246
247 begin
248 Result (1 .. Source'Length) := Source;
249
250 for J in Source'Length + 1 .. Count loop
251 Result (J) := Pad;
252 end loop;
253
254 return Result;
255 end;
256 end if;
257 end Head;
258
259 procedure Head
260 (Source : in out String;
261 Count : Natural;
262 Justify : Alignment := Left;
263 Pad : Character := Space)
264 is
265 begin
266 Move (Source => Head (Source, Count, Pad),
267 Target => Source,
268 Drop => Error,
269 Justify => Justify,
270 Pad => Pad);
271 end Head;
272
273 ------------
274 -- Insert --
275 ------------
276
277 function Insert
278 (Source : String;
279 Before : Positive;
280 New_Item : String) return String
281 is
282 Result : String (1 .. Source'Length + New_Item'Length);
283 Front : constant Integer := Before - Source'First;
284
285 begin
286 if Before not in Source'First .. Source'Last + 1 then
287 raise Index_Error;
288 end if;
289
290 Result (1 .. Front) :=
291 Source (Source'First .. Before - 1);
292 Result (Front + 1 .. Front + New_Item'Length) :=
293 New_Item;
294 Result (Front + New_Item'Length + 1 .. Result'Last) :=
295 Source (Before .. Source'Last);
296
297 return Result;
298 end Insert;
299
300 procedure Insert
301 (Source : in out String;
302 Before : Positive;
303 New_Item : String;
304 Drop : Truncation := Error)
305 is
306 begin
307 Move (Source => Insert (Source, Before, New_Item),
308 Target => Source,
309 Drop => Drop);
310 end Insert;
311
312 ----------
313 -- Move --
314 ----------
315
316 procedure Move
317 (Source : String;
318 Target : out String;
319 Drop : Truncation := Error;
320 Justify : Alignment := Left;
321 Pad : Character := Space)
322 is
323 Sfirst : constant Integer := Source'First;
324 Slast : constant Integer := Source'Last;
325 Slength : constant Integer := Source'Length;
326
327 Tfirst : constant Integer := Target'First;
328 Tlast : constant Integer := Target'Last;
329 Tlength : constant Integer := Target'Length;
330
331 function Is_Padding (Item : String) return Boolean;
332 -- Check if Item is all Pad characters, return True if so, False if not
333
334 function Is_Padding (Item : String) return Boolean is
335 begin
336 for J in Item'Range loop
337 if Item (J) /= Pad then
338 return False;
339 end if;
340 end loop;
341
342 return True;
343 end Is_Padding;
344
345 -- Start of processing for Move
346
347 begin
348 if Slength = Tlength then
349 Target := Source;
350
351 elsif Slength > Tlength then
352
353 case Drop is
354 when Left =>
355 Target := Source (Slast - Tlength + 1 .. Slast);
356
357 when Right =>
358 Target := Source (Sfirst .. Sfirst + Tlength - 1);
359
360 when Error =>
361 case Justify is
362 when Left =>
363 if Is_Padding (Source (Sfirst + Tlength .. Slast)) then
364 Target :=
365 Source (Sfirst .. Sfirst + Target'Length - 1);
366 else
367 raise Length_Error;
368 end if;
369
370 when Right =>
371 if Is_Padding (Source (Sfirst .. Slast - Tlength)) then
372 Target := Source (Slast - Tlength + 1 .. Slast);
373 else
374 raise Length_Error;
375 end if;
376
377 when Center =>
378 raise Length_Error;
379 end case;
380
381 end case;
382
383 -- Source'Length < Target'Length
384
385 else
386 case Justify is
387 when Left =>
388 Target (Tfirst .. Tfirst + Slength - 1) := Source;
389
390 for I in Tfirst + Slength .. Tlast loop
391 Target (I) := Pad;
392 end loop;
393
394 when Right =>
395 for I in Tfirst .. Tlast - Slength loop
396 Target (I) := Pad;
397 end loop;
398
399 Target (Tlast - Slength + 1 .. Tlast) := Source;
400
401 when Center =>
402 declare
403 Front_Pad : constant Integer := (Tlength - Slength) / 2;
404 Tfirst_Fpad : constant Integer := Tfirst + Front_Pad;
405
406 begin
407 for I in Tfirst .. Tfirst_Fpad - 1 loop
408 Target (I) := Pad;
409 end loop;
410
411 Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source;
412
413 for I in Tfirst_Fpad + Slength .. Tlast loop
414 Target (I) := Pad;
415 end loop;
416 end;
417 end case;
418 end if;
419 end Move;
420
421 ---------------
422 -- Overwrite --
423 ---------------
424
425 function Overwrite
426 (Source : String;
427 Position : Positive;
428 New_Item : String) return String
429 is
430 begin
431 if Position not in Source'First .. Source'Last + 1 then
432 raise Index_Error;
433 end if;
434
435 declare
436 Result_Length : constant Natural :=
437 Integer'Max
438 (Source'Length,
439 Position - Source'First + New_Item'Length);
440
441 Result : String (1 .. Result_Length);
442 Front : constant Integer := Position - Source'First;
443
444 begin
445 Result (1 .. Front) :=
446 Source (Source'First .. Position - 1);
447 Result (Front + 1 .. Front + New_Item'Length) :=
448 New_Item;
449 Result (Front + New_Item'Length + 1 .. Result'Length) :=
450 Source (Position + New_Item'Length .. Source'Last);
451 return Result;
452 end;
453 end Overwrite;
454
455 procedure Overwrite
456 (Source : in out String;
457 Position : Positive;
458 New_Item : String;
459 Drop : Truncation := Right)
460 is
461 begin
462 Move (Source => Overwrite (Source, Position, New_Item),
463 Target => Source,
464 Drop => Drop);
465 end Overwrite;
466
467 -------------------
468 -- Replace_Slice --
469 -------------------
470
471 function Replace_Slice
472 (Source : String;
473 Low : Positive;
474 High : Natural;
475 By : String) return String
476 is
477 begin
478 if Low > Source'Last + 1 or else High < Source'First - 1 then
479 raise Index_Error;
480 end if;
481
482 if High >= Low then
483 declare
484 Front_Len : constant Integer :=
485 Integer'Max (0, Low - Source'First);
486 -- Length of prefix of Source copied to result
487
488 Back_Len : constant Integer :=
489 Integer'Max (0, Source'Last - High);
490 -- Length of suffix of Source copied to result
491
492 Result_Length : constant Integer :=
493 Front_Len + By'Length + Back_Len;
494 -- Length of result
495
496 Result : String (1 .. Result_Length);
497
498 begin
499 Result (1 .. Front_Len) := Source (Source'First .. Low - 1);
500 Result (Front_Len + 1 .. Front_Len + By'Length) := By;
501 Result (Front_Len + By'Length + 1 .. Result'Length) :=
502 Source (High + 1 .. Source'Last);
503 return Result;
504 end;
505
506 else
507 return Insert (Source, Before => Low, New_Item => By);
508 end if;
509 end Replace_Slice;
510
511 procedure Replace_Slice
512 (Source : in out String;
513 Low : Positive;
514 High : Natural;
515 By : String;
516 Drop : Truncation := Error;
517 Justify : Alignment := Left;
518 Pad : Character := Space)
519 is
520 begin
521 Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad);
522 end Replace_Slice;
523
524 ----------
525 -- Tail --
526 ----------
527
528 function Tail
529 (Source : String;
530 Count : Natural;
531 Pad : Character := Space) return String
532 is
533 subtype Result_Type is String (1 .. Count);
534
535 begin
536 if Count < Source'Length then
537 return Result_Type (Source (Source'Last - Count + 1 .. Source'Last));
538
539 -- Pad on left
540
541 else
542 declare
543 Result : Result_Type;
544
545 begin
546 for J in 1 .. Count - Source'Length loop
547 Result (J) := Pad;
548 end loop;
549
550 Result (Count - Source'Length + 1 .. Count) := Source;
551 return Result;
552 end;
553 end if;
554 end Tail;
555
556 procedure Tail
557 (Source : in out String;
558 Count : Natural;
559 Justify : Alignment := Left;
560 Pad : Character := Space)
561 is
562 begin
563 Move (Source => Tail (Source, Count, Pad),
564 Target => Source,
565 Drop => Error,
566 Justify => Justify,
567 Pad => Pad);
568 end Tail;
569
570 ---------------
571 -- Translate --
572 ---------------
573
574 function Translate
575 (Source : String;
576 Mapping : Maps.Character_Mapping) return String
577 is
578 Result : String (1 .. Source'Length);
579
580 begin
581 for J in Source'Range loop
582 Result (J - (Source'First - 1)) := Value (Mapping, Source (J));
583 end loop;
584
585 return Result;
586 end Translate;
587
588 procedure Translate
589 (Source : in out String;
590 Mapping : Maps.Character_Mapping)
591 is
592 begin
593 for J in Source'Range loop
594 Source (J) := Value (Mapping, Source (J));
595 end loop;
596 end Translate;
597
598 function Translate
599 (Source : String;
600 Mapping : Maps.Character_Mapping_Function) return String
601 is
602 Result : String (1 .. Source'Length);
603 pragma Unsuppress (Access_Check);
604
605 begin
606 for J in Source'Range loop
607 Result (J - (Source'First - 1)) := Mapping.all (Source (J));
608 end loop;
609
610 return Result;
611 end Translate;
612
613 procedure Translate
614 (Source : in out String;
615 Mapping : Maps.Character_Mapping_Function)
616 is
617 pragma Unsuppress (Access_Check);
618 begin
619 for J in Source'Range loop
620 Source (J) := Mapping.all (Source (J));
621 end loop;
622 end Translate;
623
624 ----------
625 -- Trim --
626 ----------
627
628 function Trim
629 (Source : String;
630 Side : Trim_End) return String
631 is
632 Low, High : Integer;
633
634 begin
635 Low := Index_Non_Blank (Source, Forward);
636
637 -- All blanks case
638
639 if Low = 0 then
640 return "";
641
642 -- At least one non-blank
643
644 else
645 High := Index_Non_Blank (Source, Backward);
646
647 case Side is
648 when Strings.Left =>
649 declare
650 subtype Result_Type is String (1 .. Source'Last - Low + 1);
651
652 begin
653 return Result_Type (Source (Low .. Source'Last));
654 end;
655
656 when Strings.Right =>
657 declare
658 subtype Result_Type is String (1 .. High - Source'First + 1);
659
660 begin
661 return Result_Type (Source (Source'First .. High));
662 end;
663
664 when Strings.Both =>
665 declare
666 subtype Result_Type is String (1 .. High - Low + 1);
667
668 begin
669 return Result_Type (Source (Low .. High));
670 end;
671 end case;
672 end if;
673 end Trim;
674
675 procedure Trim
676 (Source : in out String;
677 Side : Trim_End;
678 Justify : Alignment := Left;
679 Pad : Character := Space)
680 is
681 begin
682 Move (Trim (Source, Side),
683 Source,
684 Justify => Justify,
685 Pad => Pad);
686 end Trim;
687
688 function Trim
689 (Source : String;
690 Left : Maps.Character_Set;
691 Right : Maps.Character_Set) return String
692 is
693 High, Low : Integer;
694
695 begin
696 Low := Index (Source, Set => Left, Test => Outside, Going => Forward);
697
698 -- Case where source comprises only characters in Left
699
700 if Low = 0 then
701 return "";
702 end if;
703
704 High :=
705 Index (Source, Set => Right, Test => Outside, Going => Backward);
706
707 -- Case where source comprises only characters in Right
708
709 if High = 0 then
710 return "";
711 end if;
712
713 declare
714 subtype Result_Type is String (1 .. High - Low + 1);
715
716 begin
717 return Result_Type (Source (Low .. High));
718 end;
719 end Trim;
720
721 procedure Trim
722 (Source : in out String;
723 Left : Maps.Character_Set;
724 Right : Maps.Character_Set;
725 Justify : Alignment := Strings.Left;
726 Pad : Character := Space)
727 is
728 begin
729 Move (Source => Trim (Source, Left, Right),
730 Target => Source,
731 Justify => Justify,
732 Pad => Pad);
733 end Trim;
734
735 end Ada.Strings.Fixed;