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