reader.pas

   1 unit reader;
   2
   3 interface
   4
   5 function  compare(_ts, _ms : string) : boolean;
   6 procedure setvar (  vn, vv : string);
   7 function  getvar (      vn : string) : string;
   8 function  parstr                     : string;
   9 procedure setglo (  vn, vv : string);
  10 function  getglo (      vn : string) : string;
  11 function  parse  (      vn : string; al : boolean) : string;
  12 procedure freeglob;
  13
  14 implementation
  15
  16 uses UStr, Serv, UWrd;
  17
  18 type
  19     trec = record
  20               name : string[12];
  21               valu : string[255];
  22               next : pointer;
  23            end;
  24
  25 var
  26     fvar,
  27     fglo : pointer;
  28     vrec,
  29     vglo,
  30     rrec : ^trec;
  31     v,
  32     z    : string;
  33
  34 function compare;
  35 label fail, succ;
  36 var i,
  37     j,
  38     n : integer;
  39    ts,
  40    ms : string;
  41
  42 procedure freelist;
  43 begin
  44    vrec := fvar;
  45    while vrec <> nil do begin
  46       rrec := vrec;
  47       vrec := vrec^.next;
  48       freemem(rrec, sizeof(trec));
  49    end;
  50    fvar := nil;
  51 end;
  52
  53 begin
  54    ts := _ts;
  55    ms := _ms;
  56    i := 1;
  57    j := 1;
  58    compare := true;
  59    freelist;
  60    repeat
  61       if (i > length(ts)) and (j > length(ms)) then goto succ;
  62       if (i > length(ts)) or  (j > length(ms)) then goto fail;
  63       if ts[i] = ms[j] then begin
  64          inc(i);
  65          inc(j);
  66          if j > length(ms) then goto succ;
  67       end else
  68       if ts[i] = '?' then begin
  69          inc(i);
  70          inc(j);
  71       end else
  72       if ts[i] = '*' then begin
  73          inc(i);
  74          if i > length(ts) then goto succ;
  75          z := copy(ts, i, 255);
  76          if pos('*', z) > 0 then z := copy(z, 1, pos('*', z) - 1);
  77          if pos('?', z) > 0 then z := copy(z, 1, pos('?', z) - 1);
  78          if pos('%', z) > 0 then z := copy(z, 1, pos('%', z) - 1);
  79          while (j <= length(ms)) and (copy(ms, j, length(z)) <> z) do begin
  80             while (j < length(ms)) and (ms[j] <> ts[i]) do inc(j);
  81             if j > length(ms) then goto fail;
  82             if copy(ms, j, length(z)) <> z then inc(j);
  83          end;
  84       end else
  85       if ts[i] = '%' then begin
  86          inc(i);
  87          n := i;
  88          while (i <= length(ts)) and (ts[i] <> '%') do inc(i);
  89          if i > length(ts) then goto fail;
  90          v := copy(ts, n, i - n);
  91          v := upst(v);
  92          inc(i);
  93          n := j;
  94          if i <= length(ts) then begin
  95             while (j <= length(ms)) and (ms[j] <> ts[i]) do inc(j);
  96             if j > length(ms) then goto fail;
  97          end else begin
  98             j := length(ms) + 1;
  99          end;
 100          z := copy(ms, n, j - n);
 101          if fvar = nil then begin
 102             getmem(fvar, sizeof(trec));
 103             vrec := fvar;
 104          end else begin
 105             getmem(vrec^.next, sizeof(trec));
 106             vrec := vrec^.next;
 107          end;
 108          fillchar(vrec^, sizeof(trec), #0);
 109          vrec^.name := v;
 110          vrec^.valu := z;
 111          if fglo = nil then begin
 112             getmem(fglo, sizeof(trec));
 113             vglo := fglo;
 114             rrec := fglo;
 115             fillchar(vglo^, sizeof(trec), #0);
 116          end else begin
 117             rrec := fglo;
 118             while (rrec <> nil) and (rrec^.name <> v) do begin
 119                vglo := rrec;
 120                rrec := rrec^.next;
 121             end;
 122             if rrec = nil then begin
 123                getmem(vglo^.next, sizeof(trec));
 124                vglo := vglo^.next;
 125                rrec := vglo;
 126                fillchar(vglo^, sizeof(trec), #0);
 127             end;
 128          end;
 129          rrec^.name := v;
 130          rrec^.valu := z;
 131       end else begin
 132          if (i > 1) and (j > i) then
 133          if compare(ts, copy(ms, j, length(ms) - j + 1)) then goto succ
 134                                                          else goto fail
 135                                 else goto fail;
 136       end;
 137    until false;
 138 fail:
 139    compare := false;
 140    freelist;
 141    exit;
 142 succ:
 143    exit;
 144 end;
 145
 146 procedure setvar;
 147 begin
 148    vglo := fvar;
 149    while vglo <> Nil do begin
 150       if vglo^.name = UpSt(vn) then break;
 151       vglo := vglo^.next;
 152    end;
 153    if vglo = Nil then vglo := NewEList(fvar, sizeof(trec), false);
 154    vglo^.name := UpSt(vn);
 155    vglo^.valu := vv;
 156 end;
 157
 158 function  getvar;
 159 var
 160    tv : string;
 161 begin
 162    getvar := '';
 163    vrec := fvar;
 164    tv := vn;
 165    tv := upst(tv);
 166    while vrec <> nil do begin
 167       if vrec^.name = tv then begin
 168          getvar := vrec^.valu;
 169          exit;
 170       end;
 171       vrec := vrec^.next;
 172    end;
 173 end;
 174
 175 procedure setglo;
 176 begin
 177    vglo := fglo;
 178    while vglo <> Nil do begin
 179       if vglo^.name = UpSt(vn) then break;
 180       vglo := vglo^.next;
 181    end;
 182    if vglo = Nil then vglo := NewEList(fglo, sizeof(trec), false);
 183    vglo^.name := UpSt(vn);
 184    vglo^.valu := vv;
 185 end;
 186
 187 function  getglo;
 188 var
 189    tv : string;
 190 begin
 191    getglo := '';
 192    vglo := fglo;
 193    tv := vn;
 194    tv := upst(tv);
 195    while vglo <> nil do begin
 196       if vglo^.name = tv then begin
 197          getglo := vglo^.valu;
 198          exit;
 199       end;
 200       vglo := vglo^.next;
 201    end;
 202 end;
 203
 204 procedure freeglob;
 205 begin
 206    vglo := fglo;
 207    while vglo <> nil do begin
 208       rrec := vglo;
 209       vglo := vglo^.next;
 210       freemem(rrec, sizeof(trec));
 211    end;
 212    fglo := nil;
 213 end;
 214
 215 function parstr;
 216 var
 217    tv : string;
 218 begin
 219    tv := '';
 220    vrec := fvar;
 221    while vrec <> nil do begin
 222       tv := tv + ' ' + vrec^.valu;
 223       vrec := vrec^.next;
 224    end;
 225    parstr := tv;
 226 end;
 227
 228 function parse;
 229 var i,
 230     p : integer;
 231     s : string;
 232    rs : string;
 233 begin
 234    s := '';
 235    i := 0;
 236    repeat
 237       inc(i);
 238       rs := wordn(vn, '%', i + 1);
 239       rs := getglo(rs);
 240       s  := s + wordn(vn, '%', i);
 241       p  := wordp(vn, '%', i + 1);
 242       if p > 0 then begin
 243          if al then s  := copy(s, 1, p - 2);
 244          if al then s  := s + space(p - 2 - length(s));
 245       end;
 246       s  := s + rs;
 247       if rs <> '' then inc(i);
 248    until i > words(vn, '%');
 249    parse := s;
 250 end;
 251
 252 begin
 253    fvar := nil;
 254    fglo := nil;
 255 end.