perm filename FETCH1.SIM[SIM,SYS] blob sn#460048 filedate 1979-07-20 generic text, type T, neo UTF8
OPTIONS(/external);
EXTERNAL REF (Infile) PROCEDURE findinfile;
EXTERNAL REF (Directfile) PROCEDURE finddirectfile;
EXTERNAL REF (Outfile) PROCEDURE findoutfile;
EXTERNAL TEXT PROCEDURE conc,upcase,frontstrip,rest,checkextension;
EXTERNAL CHARACTER PROCEDURE fetchar,findtrigger;
EXTERNAL LONG REAL PROCEDURE scanreal;
EXTERNAL INTEGER PROCEDURE checkreal,checkint,scanint,ilog;
EXTERNAL BOOLEAN PROCEDURE menu;
EXTERNAL CLASS dahelp,safeio;
EXTERNAL CLASS dbmtxt,dbm,dbmset;


dbmset CLASS fetch1(helpfilename);
VALUE helpfilename; TEXT helpfilename;
BEGIN
  REF (dahelp) helpfil;
  REAL tolerans;
  BOOLEAN booltemp;
  REF (rspec) rtyp;
  TEXT err;
  TEXT ARRAY ops[1:8];
  REF (condition) ARRAY rconds(1:20);

  CLASS condition(vpos,op,konst,next);
  INTEGER vpos,op; TEXT konst; REF (condarray) next;;

  CLASS condarray(orconnect,dim); BOOLEAN orconnect; INTEGER dim;
  BEGIN REF (condition) ARRAY conds(0:dim);
    IF dim > 0 THEN
    FOR k←←:=1 STEP 1 UNTIL dim DO conds(k←←):-rconds(k←←);
  END of condarray;


  BOOLEAN  PROCEDURE allhelp;
  BEGIN  TEXT texti;
    helpfil.helplist(mainprompt.Strip);
    Inimage;
    texti:-Sysin.Image;
    IF texti=/= NOTEXT
    THEN helpfil.helplist(texti.Strip);
  END allhelp;

  BOOLEAN PROCEDURE tcheck(k,w,err); NAME err;
  INTEGER k; TEXT w; BOOLEAN err;
  BEGIN
    err:=FALSE;
    IF k < 3 THEN
    BEGIN ! check type for inreger,real;
      IF k = 1 THEN
      BEGIN
	IF checkint(w) > 0 AND checkint(w) = 0 THEN
	err:=FALSE ELSE err:=TRUE;
      END ELSE
      IF checkreal(w) > 0 AND checkreal(w) = 0 THEN
      err:=FALSE ELSE err:=TRUE;
      tcheck:=err;
    END;
  END of tcheck;



  PROCEDURE prompt;
  BEGIN
    TEXT ARRAY errmess[1:3];
    INTEGER  tantal,keypos,i,m,n,k,iin;
    REAL rin;
    TEXT t,klass,textvar,tin,tarea,err;
    BOOLEAN prompting,error;
    REF(rspec)  r;
    TEXT ARRAY terms[1:40];

    TEXT PROCEDURE addkvot(t); TEXT t;
    BEGIN TEXT v; CHARACTER c,cc; BOOLEAN alfastring;
      BOOLEAN PROCEDURE nextalfa;
      BEGIN IF t.More THEN
	BEGIN
	  cc:=t.Getchar; t.Setpos(t.Pos-1);
	  IF NOT Digit(cc) AND cc \= cdelim AND cc \= ' ' THEN
	  nextalfa:=TRUE;
	END;
      END of nextalfa;
      v:-Blanks(t.Length+40);
      c:=' '; WHILE c = ' ' DO
      IF t.More THEN c:=t.Getchar;
      IF c \= cdelim AND NOT Digit(c) THEN
      BEGIN alfastring:=TRUE; v.Putchar(cdelim); END;
      WHILE t.More DO
      BEGIN
	IF c = ' ' THEN
	BEGIN
	  IF alfastring THEN v.Putchar(cdelim);
	  IF nextalfa THEN alfastring := TRUE ELSE alfastring := FALSE;
	  v.Putchar(c);
	  IF alfastring THEN v.Putchar(cdelim);
	END ELSE v.Putchar(c);
	c:=t.Getchar;
      END;
      v.Putchar(c);
      IF alfastring THEN v.Putchar(cdelim);
      addkvot:-v.Strip;
    END of addkvot;

    BOOLEAN PROCEDURE checktype;
    BEGIN
      IF tin = ".all" THEN GOTO fin;
      IF tcheck(m,tin,booltemp) THEN
      BEGIN err:-errmess(m); checktype:=TRUE; END ELSE
      IF m = 3 THEN putt(tin,tarea) ELSE putnumber(tin,tarea);
      fin:
    END of checktype;

    BOOLEAN PROCEDURE getspec;
    BEGIN
      IF klass =/= textvar THEN
      BEGIN
	IF klass.Sub(1,1) = "." THEN GOTO fin;
	r:-getrecordspec(klass); IF r == NONE THEN getspec :=TRUE;
      END;
      fin:
    END;

    top:
    errmess(1):-Copy("Should be integer !");
    errmess(2):-Copy("Should be real !");
    ! ask if prompting of attributes wanted;
    request("Prompting of attributes ?","YES",
    boolinput(prompting),"?",allhelp);

    ! REQUEST NEXT RECORD TYPE;

    textin:
    request("record type:",
    textvar,textinput(klass,\getspec),
    "There is no such record type !",allhelp);
    textvar:-klass;
    IF klass.Sub(1,1)="." THEN GOTO slut;
    tantal:=r.adim;
    IF NOT prompting THEN
    BEGIN ! comment read whole record directly;
      current←spec:-r;
      request("record: ",
      NOTEXT,textinput(tarea,TRUE),"?",disp←types);
      IF tarea == NOTEXT THEN GOTO top;
      ! check types of all data fields;
      tarea:-addkvot(tarea); ! try to add misssing quotes;
      error:=FALSE;
      FOR k:=1 STEP 1 UNTIL tantal DO
      BEGIN
	t:-locfield(tarea,k); IF t == NOTEXT THEN
	BEGIN ! to few fields or missing " ;
	  Outtext("cannot locate field nr: "); Outint(k,2);
	  Outimage; GOTO textin;
	END;
	n:=1;
	! check type for integers and reals;
	IF r.atypes(k) = 1 THEN n:=checkint(t) ELSE
	IF r.atypes(k) = 2 THEN n:=checkreal(t);
	IF n < 1 THEN
	BEGIN
	  Outtext("wrong type in field nr: "); Outint(k,2);
	  Outimage; error:=TRUE;
	END;
      END;
      IF \error THEN put←record(r,tarea);
      GOTO textin;
    END;
    tarea:-Blanks(maxrsize);
    ! add extra spaces to prompting attribute names;
    FOR k:=1 STEP 1 UNTIL tantal DO
    terms(k):-conc(r.anames(k),Copy(" "));
    FOR i:=1 STEP 1 UNTIL tantal DO
    BEGIN
      m:=r.atypes(i);
      current←spec:-r;
      IF terms(i) = "dbs←key " THEN puti(next←key,tarea) ELSE
      BEGIN
	request(terms(i),
	NOTEXT,textinput(tin,\checktype),err,disp←types);
	IF tin = ".all" THEN GOTO top;
      END;
    END;
    store←record:
    ! *** lagra posten i databasen ***;
    put←record(r,tarea);
    GOTO textin;
    slut:
  END of prompt;

  BOOLEAN PROCEDURE compare(c,r);
  REF (record) r; REF (condition) c;
  ! check that record r satisfies condition c;
  BEGIN BOOLEAN b; INTEGER i,j,k; REAL x,y;
    INTEGER vtype; TEXT v;
    SWITCH loadvarb:=int,rel,cmp;
    SWITCH comp:=eq←,less←,greater←,less←eq,
    greater←eq,not←eq;
    IF c.next =/= NONE THEN
    BEGIN b:=satisfied(c.next,r); GOTO fin; END;
    vtype:=r.spec.atypes(c.vpos); v:-r.avalues(c.vpos);
    GOTO loadvarb(vtype);
    int:  j:=c.konst.Getint; i:=v.Getint; GOTO cmp;
    rel:  x:=v.Getreal; y:=c.konst.Getreal;
    cmp:  GOTO comp(c.op);
    eq←:  IF vtype = 2 THEN b:=Abs(x-y) < tolerans ELSE
    b:=v = c.konst; GOTO fin;
    less←: IF vtype = 1 THEN b:=i<j ELSE
    IF vtype = 2 THEN
    b:= (y-x) > tolerans ELSE
    b := v < c.konst; GOTO fin;
    greater←:  IF vtype = 1 THEN b := i > j ELSE
    IF vtype = 2 THEN
    b:= (x-y) > tolerans ELSE
    b := v > c.konst; GOTO fin;
    less←eq: IF vtype = 1 THEN b:=i <= j ELSE
    IF vtype = 2 THEN
    b:= (y-x) >= tolerans ELSE
    b := v <= c.konst; GOTO fin;
    greater←eq:  IF vtype = 1 THEN b := i >= j ELSE
    IF vtype = 2 THEN
    b:= (x-y) >= tolerans ELSE
    b := v >= c.konst; GOTO fin;
    not←eq:  IF vtype = 2 THEN b:=Abs(x-y) > tolerans ELSE
    b:= v \= c.konst;
    fin:
    compare := b;
  END of compare;

  BOOLEAN PROCEDURE checkc(t,rc,rcx);
  NAME rcx;
  TEXT t; REF (condition) ARRAY rc; INTEGER rcx;
  ! check that text t is a condition of the form:
  !	ATTRIBUTE  OPERATTOR  CONSTANT
  ! operators allowed: =   <   >   <=   >=   \=
  ;
  BEGIN
    INTEGER k,m,n; TEXT u,v,w; CHARACTER c;
    BOOLEAN orcond;
    IF t == NOTEXT THEN GOTO fin;
    IF t = ".or" OR t = ".OR" THEN orcond:=TRUE;
    IF orcond OR t = ".and" OR t = ".AND"  THEN
    BEGIN
      rcx:=rcx+1; currentfile.Setpos(0);
      rc(rcx):-NEW condition(0,0,NOTEXT,readconds(orcond));
      GOTO fin;
    END;
    k:=loc(t,'<',nullc);
    IF k = 0 THEN
    BEGIN t.Setpos(1); k:=loc(t,'>',nullc); END;
    IF k = 0 THEN
    BEGIN t.Setpos(1); k:=loc(t,'\',nullc); END;
    IF k = 0 THEN
    BEGIN t.Setpos(1); k:=loc(t,'=',nullc); END;
    IF k = 0 THEN
    BEGIN
      err:-Copy("operator missing ? ");
      checkc:=TRUE; GOTO fin;
    END;
    m:=k; c:=t.Getchar;
    t:-upcase(t.Strip);
    u:-t.Sub(1,k-2).Strip;
    ! check if two-byte operator;
    IF c = '=' OR c = '\' THEN k:=k+1;
    v:-t.Sub(m-1,k-m+1); w:-t.Sub(k,t.Length-k+1);
    ! remove leading spaces from w;
    c:=' '; WHILE w.More AND c = ' ' DO c:=w.Getchar;
    w:-w.Sub(w.Pos-1,w.Length-w.Pos+2);
    ! check that left part is an attribute of current record type;
    m:=loctext(u,rtyp.anames);
    IF m = 0 THEN
    BEGIN
      err:-Copy("invalid attribute ? ");
      checkc:=TRUE; GOTO fin;
    END;
    IF tcheck(rtyp.atypes(m),w,booltemp) THEN
    BEGIN
      checkc:=TRUE;
      err:-Copy("Wrong type on right part ");
      GOTO fin;
    END;
    k:=loctext(v,ops); IF k = 0 THEN
    BEGIN
      err:-Copy("invalid operator ? ");
      checkc:=TRUE; GOTO fin;
    END;
    rcx:=rcx+1;
    rc(rcx):-NEW condition(m,k,w,NONE);
    fin:
  END of checkc;

  REF (condarray) PROCEDURE readconds(orcond);
  BOOLEAN orcond;
  ! read conditions for retrival and check them;
  BEGIN TEXT t; INTEGER k;
    REF (condition) ARRAY rcarr(1:20); INTEGER rcx;
    rcx:=0;
    next:
    request("*",NOTEXT,textinput(t,\checkc(t,rcarr,rcx)),
    err,allhelp);
    IF t =/= NOTEXT THEN GOTO next;
    FOR k:=1 STEP 1 UNTIL rcx DO rconds(k):-rcarr(k);
    readconds:-NEW condarray(orcond,rcx);
  END of readconds;

  BOOLEAN PROCEDURE satisfied(carr,r);
  REF (condarray) carr; REF (record) r;
  BEGIN INTEGER k;
    INSPECT carr DO
    BEGIN
      IF dim = 0 THEN GOTO yes;
      FOR k:=1 STEP 1 UNTIL dim DO
      BEGIN
	IF compare(conds(k),r) THEN
	BEGIN IF orconnect THEN GOTO yes; END ELSE
	IF NOT orconnect THEN GOTO fin;
      END;
      IF orconnect THEN GOTO fin;
    END;
    yes: satisfied:=TRUE;
    fin:
  END of satisfied;

  helpfil:-NEW dahelp(helpfilename);

END of fetch1;