perm filename FETCH.SIM[SIM,SYS] blob sn#460047 filedate 1979-07-20 generic text, type T, neo UTF8
BEGIN
  OPTIONS(/-W);
  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,fetch2;
  fetch2("ftclog.tmp","English","fetch.hda") BEGIN

    SWITCH opchoice:=record←,and←,or←,select←,invert←,display←,index←,
    tty←,set←,fields←,insert←,define←,nextkey,update←,finish,type←,
    owner←,pool←,remove←,delete←,table←;

    ! start of main program  ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←;

    doforeach("SETSPEC",makesetspec);
    margin:=0; displaydefault:=FALSE;
    tolerans:=0.001;
    fx:=1; invx(1):-Blanks(40);
optot:-Copy("+++0AND0OR 0SEL0INV0DIS1IND1TTY0SET2FIE1INS3DEF3RRR0UPD0EXI0TYP1
OWN2POO1REM2DEL1TAB0");
    FOR k:=1 STEP 1 UNTIL 21 DO
    BEGIN
      oparr(k):-optot.Sub(k*4-3,3);
      opargs(k):=optot.Sub(k*4,1).Getint;
    END;

    ops(1):-Copy("="); ops(2):-Copy("<");
    ops(3):-Copy(">"); ops(4):-Copy("<=");
    ops(5):-Copy(">="); ops(6):-Copy("\=");
    start:
    nextkey:
    request(">",
    nodefault,textinput(keyvalue,TRUE),"?",allhelp);
    nrof←hits:=0;
    GOTO opchoice(oper);
    and←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  AND  ;
    orconnections:=FALSE; scan; GOTO nextkey;
    or←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  OR  ;
    orconnections:=TRUE; scan; GOTO nextkey;
    select←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  SELECT  ;
    fx:=1; invx(fx):-Blanks(240);
    lmax:=0;
    select; GOTO nextkey;
    invert←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  INVERT  ;
    fileout:=TRUE; GOTO nextkey;
    display←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  DISPLAY  ;
    IF index←ok THEN
    BEGIN
      filewrite:=fileout:=FALSE; fx:=1;
      IF opa(3) =/= NOTEXT THEN nameonly:=TRUE;
      scanindex(tabulate); fx:=fx-1;
      nameonly:=FALSE;
    END;
    IF rtypsave =/= NONE THEN rtyp:-rtypsave;
    GOTO nextkey;
    index←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  INDEX  ;
    IF opa(3) =/= NOTEXT THEN
    BEGIN
      fx:=opa(2).Getint;
      IF fx = 0 THEN scanagain:=FALSE;
    END ELSE
    BEGIN
      scanagain:=TRUE; fx:=1;
      index←ok;
    END;
    GOTO nextkey;
    tty←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  TTY  ;
    BEGIN
      filewrite:=FALSE;
    fileout:=FALSE; GOTO nextkey; END;
    set←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  SET;
    IF setcheck(opa(2)) THEN GOTO nextkey;
    rowner:-getnew(opa(3),otype);
    IF rowner == NONE THEN
    BEGIN outline("Nonexistent record !"); GOTO nextkey; END;
    IF opa(4) =/= NOTEXT THEN nameonly:=TRUE;
    mapset(rowner,opa(2),tabulate);
    nameonly:=FALSE;
    GOTO nextkey;
    fields←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  FIELDS;
    current←spec:-getrecordspec(opa(2));
    IF current←spec == NONE THEN
    outline("Record type undefined !") ELSE disp←types;
    GOTO nextkey;
    insert←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  INSERT;
    BEGIN REF (setspec) ss;
      setname:-opa(2); owner:-opa(3); members:-opa(4);
      IF setcheck(setname) THEN GOTO nextkey;
      rowner:-getnew(owner,otype);
      IF rowner == NONE THEN
      BEGIN
	outline("Owner not found !"); GOTO nextkey;
      END;
      k:=5; WHILE members =/= NOTEXT DO
      BEGIN
	rmemb:-getnew(members,mtype);
	IF rmemb == NONE THEN
	BEGIN Outtext("Member not found: "); outline(members); END ELSE
	insert(setname,rowner,rmemb);
	members:-opa(k); k:=k+1;
      END;
      GOTO nextkey;
    END;
    define←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  DEFINE;
    defineset(opa(2),opa(3),opa(4),opa(5));
    GOTO nextkey;
    update←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  UPDATE;
    loading:=TRUE; prompt; GOTO nextkey;
    type←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  TYPE;
    recordtype:-opa(2); rtyp:-getrecordspec(recordtype);
    IF rtyp == NONE THEN
    BEGIN
      outline("There is no such type !"); display←records;
    END;
    GOTO nextkey;
    owner←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  OWNER;
    IF setcheck(opa(2)) THEN GOTO nextkey;
    rmemb:-getnew(opa(3),mtype);
    IF rmemb == NONE THEN
    BEGIN outline("Nonexistent record !"); GOTO nextkey; END;
    rowner:-getowner(rmemb,opa(2));
    IF opa(4) =/= NOTEXT THEN nameonly:=TRUE;
    IF rowner =/= NONE THEN
    tabulate(rowner); nameonly:=FALSE; GOTO nextkey;
    pool←: ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  POOL;
    ! modify size of core pool of active records;
    n:=opa(2).Getint; rpooltop:=rpooltop1:=n;
    rpoolmax:=n+n//2; rpoolmax2:=rpoolmax+1;
    IF opa(3) =/= NOTEXT THEN max←load:=opa(3).Getint;
    GOTO nextkey;
    remove←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  REMOVE;
    IF setcheck(opa(2)) THEN GOTO nextkey;
    FOR k:=3 STEP 1 UNTIL 20 DO
    BEGIN
      IF opa(k) == NOTEXT THEN GOTO nextkey;
      rmemb:-getnew(opa(k),mtype);
      remove(rmemb,opa(2));
    END;
    GOTO nextkey;
    delete←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  DELETE;
    FOR k:=2 STEP 1 UNTIL 20 DO
    BEGIN
      IF opa(k) == NOTEXT THEN GOTO nextkey;
      rmemb:-getnew(opa(k),recordtype);
      delete(rmemb);
    END;
    GOTO nextkey;
    table←:  !  ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  TABLE;
    IF opa(2) == NOTEXT THEN
    BEGIN ! ask for fields, columns and sums within delimiters;
      stringrequest("Fields::",NOTEXT,opa(2),
      TRUE,"?",nohelp);
      stringrequest("Columns::",NOTEXT,opa(3),
      TRUE,"?",nohelp);
      stringrequest("Sums::",NOTEXT,opa(4),
      TRUE,"?",nohelp);
    END ELSE split←char:=':';
    tabdim:=split(opa(2),tabnames); k:=split(opa(3),tabpos);
    IF k < tabdim THEN
    BEGIN outline("Too few columns !"); GOTO nextkey; END;
    IF k <= tabdim THEN blksize:=80 ELSE
    blksize:=fieldpos(tabdim+1):=tabpos(k).Getint;
    FOR k:=1 STEP 1 UNTIL tabdim DO sumnames(k):-NOTEXT;
    split(opa(4),sumnames);
    split←char:=',';
    FOR k:=1 STEP 1 UNTIL tabdim DO
    BEGIN
      fieldpos(k):=tabpos(k).Getint;
      IF fieldpos(k) > 0 THEN
      BEGIN
	IF tabnames(k).Strip == NOTEXT THEN fieldloc(k):=0 ELSE
	BEGIN
	  fieldloc(k):=loctext(tabnames(k),rtyp.anames);
	  IF fieldloc(k) = 0 THEN
	  BEGIN Outtext("Field undefined: ");
	    outline(tabnames(k)); GOTO nextkey;
	  END;
	END;
	sumwanted(k):=loctext(sumnames(k),rtyp.anames);
	fieldsum(k):=0;
      END;
    END;
    GOTO nextkey;
    record←:  ! ←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←←  RECORD;
    IF storeagain THEN
    BEGIN r.store; storeagain:=FALSE; END;
    r:-get(keyvalue,recordtype); IF r == NONE THEN
    BEGIN outline("            non-existent");
    GOTO nextkey; END;
    current←spec:-rtyp;
    nextterm:
    request("term: ",
    NOTEXT,textinput(tname,\getterm),"There is no such field !",disp←types);
    IF tname == NOTEXT THEN GOTO nextkey;
    IF tname = ".ALL" OR tname = ".all" THEN
    BEGIN tabulate(r); GOTO nextkey; END;
    Outtext("                ");
    outline(r.avalues(termposition));
    GOTO nextterm;
    finish:
    IF storeagain THEN r.store;
    IF tabfile =/= NONE THEN tabfile.Close;
  END;
END of fetch;