perm filename FETCH2.SIM[SIM,SYS] blob sn#460049 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,fetch1;
fetch1 CLASS fetch2;
BEGIN
  INTEGER termposition,m,n,k,lmax,nrof←hits,fx,tabdim,blksize;
  BOOLEAN fileout,orconnections,storeagain,loading,scanagain,filewrite;
  TEXT setname,otype,mtype,owner,members,strip←t;
  TEXT ARRAY tabnames,tabpos,sumnames[1:80];
  INTEGER ARRAY fieldloc,fieldpos,fieldsum,sumwanted[1:80];
  REF (Outfile) tabfile;
  TEXT ARRAY invx[1:10],opa[1:20],oparr[1:30];
  INTEGER ARRAY opargs[1:30];
  TEXT ARRAY membs[1:20]; INTEGER mcount;
  REF (lrecord) rowner,rmemb;
  TEXT newvalue,optot,t,u,datarecord,recordtype,keyvalue,tname;
  REF (rspec) rtypsave,indexspec,setspecif;
  REF (record) r;
  REF (condarray) topcond;
  CHARACTER c;

  BOOLEAN PROCEDURE getterm;
  BEGIN BOOLEAN getm;
    IF tname =/= NOTEXT AND tname \= ".ALL" AND tname \= ".all" THEN
    BEGIN
      m:=loc(tname,'=',nullc); IF m > 0 THEN
      BEGIN ! assignment to attribute;
	newvalue:-frontstrip(tname.Sub(m,tname.Length+1-m));
	t←t:-tname.Sub(1,m-2);
	tname:-nextstring;
	m:=loctext(tname,rtyp.anames);
	IF m > 0 THEN
	BEGIN
	  IF NOT tcheck(rtyp.atypes(m),newvalue,getm) THEN
	  BEGIN
	    r.avalues(m):-newvalue;
	    storeagain:=TRUE;
	  END;
	END;
      END ELSE
      m:=loctext(tname,rtyp.anames);
      IF m = 0 THEN getm:=TRUE;
      termposition:=m; getterm:=getm;
    END;
  END of getterm;

  PROCEDURE wtabfile(r); REF (record) r;
  INSPECT tabfile DO
  BEGIN INTEGER k,kk,kkk;
    FOR k:=1 STEP 1 UNTIL tabdim DO
    BEGIN
      IF fieldpos(k)<0 THEN
      BEGIN
	r:-getowner(r QUA lrecord,tabnames(k));
	IF r == NONE THEN GOTO fin;
      END ELSE
      BEGIN
	Setpos(fieldpos(k));
	IF fieldloc(k) > 0 THEN
	BEGIN
	  ! INTEGERS RIGHT ADJUSTED, THE REST LEFT ADJUSTED;
	  IF r.spec.atypes(fieldloc(k)) = 1 THEN
	  BEGIN ! locate next field position, bypass negative numbers
	    indicating moving of context via sets;
	    kkk:=0; kk:=k+1; WHILE kkk<=0 DO
	    BEGIN kkk:=fieldpos(kk); kk:=kk+1; END;
	    kkk:=kkk-fieldpos(k);
	    ! fields of type integer are right-adjusted (to allow sorting);
	    Outint(r.avalues(fieldloc(k)).Getint,kkk);
	  END ELSE
	  Outtext(r.avalues(fieldloc(k)));
	  IF sumwanted(k) > 0 THEN
	  fieldsum(k):=fieldsum(k) + r.avalues(sumwanted(k)).Getint;
	END;
      END;
    END;
    fin: Outimage;
  END of tabfile;

  PROCEDURE check←write(r); REF (record) r;
  ! check that recor satisfies all conditions in rconds
  ! if so type entire record
  ;
  BEGIN
    IF satisfied(topcond,r) THEN
    BEGIN
      IF fileout THEN puti(r.dbskey,invx(fx))  ELSE
      IF filewrite THEN wtabfile(r) ELSE tabulate(r);
      nrof←hits:=nrof←hits+1;
    END;
  END of check←write;


  BOOLEAN PROCEDURE setcheck(t); TEXT t;
  BEGIN REF (setspec) ss;
    ss:-getsetspec(t); IF ss == NONE THEN
    BEGIN
      outline("Set undefined !"); setcheck:=TRUE;
    END ELSE
    BEGIN
      set←←spec:-ss; otype:-ss.ownertype;
      mtype:-ss.membertypes(1).spec.rname;
      IF  otype == NOTEXT OR mtype == NOTEXT THEN
      BEGIN
	outline("Set not well-defined !"); setcheck:=TRUE;
      END;
    END;
  END of setcheck;

  PROCEDURE select;
  BEGIN TEXT t,u; REF (condarray) cond1;
    REF(action) slevel,slsave,f; INTEGER level;
    REF (action) ARRAY setstack[0:20];
    CLASS action(setname,owntype,membtype,conds);
    TEXT setname,owntype,membtype; REF (condarray) conds;
    BEGIN
      lmax:=lmax+1; setstack(lmax):-THIS action;
    END of action;
    PROCEDURE redefine(t); TEXT t;
    BEGIN REF (rspec) r;
      r:-getrecordspec(t);
      IF r == NONE THEN
      BEGIN outline("Record type undefined !"); GOTO fin; END;
      r.prototype:-NEW lrecord(r,noargs);
    END;
    PROCEDURE helpindex;
    BEGIN
      outline("Type either a set name to continue search , or");
      outline("   .type to type final result  or");
      outline("   .index to save result in an index file");
    END;
    PROCEDURE scanset(r); REF (lrecord) r;
    INSPECT slevel DO
    BEGIN
      IF satisfied(conds,r) THEN
      BEGIN
	IF level < lmax THEN
	BEGIN
	  level:=level+1; slsave:-slevel; slevel:-setstack(level);
	  mapset(r,setname,scanset);
	  level:=level-1; slevel:-slsave;
	END ELSE
	mapset(r,setname,check←write);
      END;
    END;
    next:
    request("Set:",
    NOTEXT,textinput(u,TRUE),"?",allhelp);
    t:-Copy(u);
    t:-upcase(t.Strip);
    IF t = ".TYPE" THEN fileout:=FALSE;
    IF t = ".INDEX" THEN fileout:=TRUE;
    IF t = ".TYPE" OR t = ".INDEX" THEN
    BEGIN
      outline("Final conditions: ");
      rtyp:-getrecordspec(otype);
      topcond:-readconds(FALSE);
      level:=1; slevel:-setstack(1);
      doforeach(slevel.owntype,scanset);
      IF fileout THEN nextstep;
    END ELSE
    BEGIN
      t:-u;
      IF setcheck(t) THEN GOTO next;
      outline("Conditions: ");
      rtyp:-getrecordspec(otype);
      cond1:-readconds(FALSE);
      f:-NEW action(t,otype,mtype,cond1);
      otype:-mtype;
      GOTO next;
    END;
    fin:
  END of select;

  PROCEDURE nextstep;
  BEGIN INTEGER max,n,m;
    Outtext("Number of hits = "); Outint(nrof←hits,3);
    Outimage;
    request("Next action: ",
    ".again",textinput(t,t.Length>1),"?",allhelp);
    t:-upcase(t);
    c:=t.Sub(2,1).Getchar;

    IF c = 'A' THEN scanagain:=TRUE
    ELSE scanagain:=FALSE;
    IF c = 'D' OR c = 'N' THEN
    BEGIN
      IF c = 'N' THEN nameonly:=TRUE; scanindex(tabulate);
      nameonly:=FALSE;
    END;
    IF c = 'I' THEN
    BEGIN
      n:=loc(t,',','/'); t:-t.Sub(n,t.Length-n+1);
      u:-Blanks(50);
      putt(t,u); puti(nrof←hits,u); putt(rtyp.rname,u);
      strip←t:-invx(fx).Strip;
      t:-conc(slash,conc(strip←t,slash));
      strip←t:-u.Strip;
      t:-conc(strip←t,t);
      do←not←buffer:=TRUE;
      put←record(getrecordspec("INDEXFILE"),t);
      do←not←buffer:=FALSE;
    END;
  END;

  PROCEDURE scanindex(p); PROCEDURE p;
  BEGIN
    t←t:-invx(fx).Strip; fx:=fx+1;
    invx(fx):-Blanks(240);
    WHILE t←t.More DO
    BEGIN
      k:=nextint; r:-getrec(k,rtyp.prototype); p(r);
    END;
  END of scanindex;


  PROCEDURE scan;
  BEGIN
    IF opa(2) =/= NOTEXT THEN
    BEGIN
      IF tabfile =/= NONE THEN tabfile.Close;
      tabfile:-NEW Outfile(opa(2));
      tabfile.Open(Blanks(blksize));
      filewrite:=TRUE;
    END ELSE filewrite:=FALSE;
    topcond:-readconds(orconnections);
    IF scanagain THEN scanindex(check←write) ELSE
    BEGIN
      fx:=1; invx(fx):-Blanks(240);
      doforeach(recordtype,check←write);
    END;
    IF fileout THEN nextstep;
    IF filewrite THEN INSPECT tabfile DO
    BEGIN
      FOR k:=1 STEP 1 UNTIL tabdim DO
      BEGIN
	IF sumwanted(k) > 0 THEN
	BEGIN
	  Image.Setpos(fieldpos(k));
	  Outtext(intput(fieldsum(k)));
	END;
      END;
      Outimage;
    END;
  END of scan;

  BOOLEAN PROCEDURE index←ok;
  BEGIN
    t:-opa(2);
    r:-get(t,"INDEXFILE");
    IF r == NONE THEN
    BEGIN
    outline("Index file not defined !"); GOTO fin; END;
    index←ok:=TRUE;
    Outtext("Nr of records = "); outline(r.avalues(2));
    rtypsave:-rtyp; rtyp:-getrecordspec(r.avalues(3));
    invx(1):-r.avalues(4);
    fin:
  END of index←ok;


  INTEGER PROCEDURE oper;
  BEGIN INTEGER n,m; TEXT t;
    t:-keyvalue;
    IF t.Sub(1,1) \= "." THEN n:=1 ELSE
    BEGIN
      FOR n:=1 STEP 1 UNTIL 20 DO opa(n):-NOTEXT;
      m:=split(t,opa);
      opa(1):-t:-upcase(t.Strip);
      IF t.Length<3 THEN BEGIN n:=0; GOTO fin; END;
      IF t.Sub(2,2) = "OR" THEN
      BEGIN n:=3; GOTO fin; END;
      IF t.Length<4 THEN n:=0 ELSE
      n:=loctext(t.Sub(2,3),oparr);
      IF n = 0 THEN GOTO fin;
      IF m-1<opargs(n) THEN
      BEGIN
	outline("Too few arguments !"); n:=13;
      END;
    END;
    fin:
    oper:=n;
    IF n = 0 THEN
    BEGIN
      outline("Illegal command !"); oper:=13;
    END;
    IF rtyp == NONE AND n < 4 THEN
    BEGIN
      oper:=13;
      outline("Please do .type,rname to specify current record type !");
    END;
  END of oper;


  REF (lrecord) PROCEDURE getnew(key,type); TEXT key,type;
  BEGIN REF (record) r;
    r:-get(key,type);
    ! make sure it is represented as an lrecord;
    IF r =/= NONE THEN
    BEGIN
      r:-locrec(r.dbskey);
      getnew:-getlrec(r QUA lrecord);
    END;
  END of getnew;

END of fetch2;