{**********************************************************************}
{*                     APMTEL Database routines                       *}
{*             Server version - direct access to file                 *}
{*                  John Butler for A.Ness project                    *}
{*                                                                    *}
{*                    Version 4.1  5 Sep 1988                         *}
{**********************************************************************}

%include "inc:util.imp"
%include "inc:region.imp"
%include "files.inc"
%include "gdmr_h:io_f.inc"
%externalstring (31) %fnspec datetime {FS 'D'}

%routine
%integerfn F write N %c
                              (%record(*)%name access,
                               %integer token1, token2, byte offset, N,
                               %integername bytes,
                               %bytename buffer,
                               %string(*)%name textual response)

!We want to be able to write arbitrary chunks into the file.
!We have available "F read block", "F read N" and "F write block"
!Crib: write region(%integer ref,byte,bytes,%bytename buffer)

!!%bytearray temp(1:532)
!!%integer count,i,lo,hi,offset,oldsize
!!%record(tokenf)%name file
!!  %returnif bytes<=0 %or byte offset<0
!!  file == record(ref)
!!  lo = byte offset>>9; hi = (byte offset+bytes-1)>>9
!!  oldsize = file_size
!!  %signal 3,4,byte offset-file_size,"Write region: off end of file" %if %c
!!  byte offset > oldsize
!!  file_size = byte offset+bytes %if byte offset+bytes>file_size
!!  file_last block = hi %if hi>file_last block
!!  offset = byte offset&511
!!  %cycle
!!    %if offset#0 %start;    {first block not aligned
!!      count = offset+bytes
!!      count = 512 %if count>512 %or byte-offset+count<oldsize
!!      i = oldsize-byte offset+offset; i = 512 %if i>512
!!      rc=F read N(access, token1, token2, offset, inlen, outlen, where,
!!      textual response)
!!      readregion(ref,byte offset-offset,i,b)
!!      i = 512-offset; i = bytes %if bytes<i
!!      move(i,buffer,b[offset])
!!      byte offset = byte offset-offset
!!      buffer == buffer[-offset]
!!      bytes = bytes+offset
!!      offset = 0
!!    %elseif lo=hi %and bytes<512  {last block incomplete
!!      %if byte offset+bytes>=oldsize %start {extending: use specified amount
!!        count = bytes
!!      %elseif oldsize>byte offset+512       {not in last block
!!        count = 512
!!      %else
!!        count = oldsize-byte offset
!!      %finish
!!      b == putnum(count,b)
!!      b == put(nl,b)
!!      %if lo<hi %or byte offset+bytes<oldsize %start
!!        i = oldsize-byte offset; i = 512 %if i>512
!!        rc = F read N
!!        readregion(ref,byte offset,i,b)
!!      %finish
!!      move(bytes,buffer,b)
!!    %else                         {complete block
!!      count = 512
!!      b == putnum(count,b)
!!      b == put(nl,b)
!!      move(512,buffer,b)
!!    %finish
!!    etherwrite(lsap,temp(1),addr(b)-addr(temp(1))+count)
!!    i = etherread(lsap,b0,255)
!!    %if b0='-' %start
!!      count = b0[1]-'0'; b0[1] = i-3
!!      %signal 3,4,count,string(addr(b0)+1)
!!    %finish
!!    byte = byte+count
!!    buffer == buffer[count]
!!    bytes = bytes-count
!!    lo = lo+1
!!  %repeatuntil lo>hi
%end

!!%externalintegerfnspec F write block %c
!!                              (%record(*)%name access,
!!                               %integer token1, token2, byte offset, bytes,
!!                               %bytename buffer,
!!                               %string(*)%name textual response)

!File organisation is now an index-sequential file with a couple of linked
!lists running through it.

!A cell here is 1024 bytes. Each cell contains a PAGE or indexing information.

!A PAGE may have 0 or many SUBPAGES.
!In Teletext terms the full page number is pppssss where ppp is the pagenumber
!and ssss is the subpage number. If ssss=0 and the only subpage is the page itself.
!The index cells point at the first or only subpage of the page.
!This has pointers to the other subpages (if any). We'll call it a HEAD Cell

!The first 12 bytes in the file are:
! 0,1: Free cell queue head.
! 2,3: Used cell chain head. This chain links the cell heads
!      in chronologica; order.
! 4,5: Used chain tail. Points to the most recent cell
! 7,8: unused
! 8-11: Timestamp of last write to file.


!The first 10 cells (bar the first 12 bytes) are index cells, each being
!2 bytes, indexed by page.  This allows up to 5114 pages (we can only use 4500)

! Page is a 16-bit channel/page number. Top 4 bits channel, bottom 12 page no.
!The head cells start with BLEN (24) bytes admin information then 1000 bytes for
!the first/only subpage. (the 25th line is not used yet). The first 10 bytes are:
! 0,1: Pointer to next subpage or 0
! 2,3: Forward pointer to next head cell
! 4,5: Reverse pointer to last head cell
! 6,7: Page id
! 8-11: Timestamp (offset must equal tst offset below)

%recordformat admin fm(( %c
   (%half free head, busy head, busy tail) %c
%or %c
   (%half cell ptr, fwd link, rev link) %c
), %half page id, %integer timestamp)

%constinteger blk0admin = 12, blknadmin=12, indexblks=5, pageblks = 15, {testing}
   tst offset = 6, blen=24

%constinteger true=1,false=0

%owninteger file ref=0


!!%integerfn open(%string(255) cache file, %integername file size, %integer mode)
!!   ! Attempt to open one of the database files.   success = 1, failure = -1
!!   ! Note use of global FILE REF
!!   %on %event 0,1,2,3,4,5,6,7,8,9 %start
!!      %if event_event = 3 %and event_sub = 3 %start
!!         printstring("Catastrophic user cache error - Event ")
!!         write(event_event,-1); space; write(event_sub,-1); newline
!!         printstring(event_message." - ".itos(event_extra,-1)); newline
!!         %stop
!!      %finish
!!      %result= -1
!!   %finish
!!
!!   file ref=0
!!   accessfile(cache file ,mode, file ref,file size)
!!   %result= 1
!!%end

%owninteger token1, token2, flags
%ownstring (255) textRC

%routine stop on error(%integer rc, %string (255) text)
   %if rc#0 %then printline("Stopped on rc=".itos(rc,-1)." ".text) %and %stop
%end

%externalintegerfn open cache(%string(255) cache file)
   ! Repeat a re-open of the database file until it succeeds
   ! Open it in write mode.
   %integer file size
   
   %result = F open file( %c
   nil, cache file,
   read file mode ! modify file mode, read file mode ! modify file mode, 0,
   token 1, token 2, file size, flags, textRC)
   printstring("Open cache ")
   phex(token1); space; phex(token2); space; phex(flags); space; printline(textRC)
%end


%externalroutine close cache
   ! Close the database file for use by other users
   %integer rc
   rc = F close file(nil, token 1, token 2, flags, textRC)
%end

   
%routine read cell(%integer cell, offset, inlen, %name to)
   %integer rc
!! printstring("ReadCell: "); write(cell, 3);space; phex(offset)
!! space; write(inlen, 3); space; phex(addr(to))
   rc = F read N(nil, token1, token2, cell*1024+offset, inlen, outlen, to, textRC)
!!!read region(file ref, cell*1024+offset, inlen, to)
!! printstring("="); phex(to); newline
%end

%routine move(%integer bytes, %name from, to)
   !Move BYTES bytes from FROM to TO. Pinched from IE.
   !If addr(FROM) < addr(TO) do the move from the top down to allow overlap
   %return %if Bytes = 0 %or  From == To

   %if Addr (To) < Addr (From) %start
      *Subq.l #1, d0
   f loop:
      *move.b (a0)+, (a1)+
      *dbra   d0, f loop
   %else
      *add.l  d0, a0
      *add.l  d0, a1
      *subq.l #1, d0
   b loop:
      *move.b -(a0), -(a1)
      *dbra   d0, b loop
   %finish
%end

%routine read admin(%integer cell, %name admin)
    %bytearray buff(0:511)
    %integer rc, blklen
    rc = F read block(nil, token1, token2, cell*1024, blklen, buff(0), textRC)
    stop on error(rc, textRC)
    move(blknadmin, buff(0), admin)
%end

%routine write to cell(%integer cell, offset, bytes, %name from)
   %integer rc
!! printstring("WriteCell: "); write(cell, 3);space; phex(offset)
!! space; write(bytes, 3); space; phex(addr(from))
!! printstring("="); phex(from); newline
   rc = F write block(nil, token1, token2, cell*1024+offset, bytes, from, textRC)
!!!write region(file ref, cell*1024+offset, bytes, from)
%end

%integerfn kday(%integer d,m,y)
      !Days since 1/1/1900
      %if m>2 %then m=m-3 %else m=m+9 %and y=y-1
      %result=1461*y//4+(153*m+2)//5+d+58
%end; ! of kday

%routine kdate(%integername d,m,y,%integer k)
   !Convert timestamp k to d,m,y.   k is days since 1/1/1900. 2 digit y
   %integer w
   k=k+693902; ! days since Cleopatras birthday
   w=4*k-1
   y=w//146097
   k=w-146097*y
   d=k//4
   k=(4*d+3)//1461;  d=4*d+3-1461*k;  d=(d+4)//4
   m=(5*d-3)//153;   d=5*d-3-153*m;   d=(d+5)//5
   y=k
   %if m<10 %then m=m+3 %else %start
      m=m-9
      %if y=99 %then y = 0 %else y=y+1
   %finish
%end; ! of kdate

%integerfn timestamp
   %integer dd,mm,yy,hh,nn,magic
   %string(31)t
   t = datetime
   dd=stoi(substring(t,1,2)); mm=stoi(substring(t, 4,5)); yy=stoi(substring(t, 7,8))
   hh=stoi(substring(t,11,12)); nn=stoi(substring(t,14,15))
   magic = ((kday(dd,mm,yy)-31411)*24+hh)*60+nn
   !23-bit integer (minutes since 1/1/86)
   !31411 is the day no for 1/1/86.   
   !Date part of magic won't overflow this century.
   %result = magic
%end

%routine readstamp(%record (admin fm) %name adm, %integername d,m,y, h,n)
   %integer dstamp, tstamp
   tstamp = adm_timestamp; dstamp = tstamp//(24*60)
   kdate(d,m,y, dstamp+31411)
   tstamp = tstamp - dstamp*24*60
   h = tstamp//60
   n = tstamp - h*60
%end

%externalroutine create db file(%string (255) filename, %integer indexblks, pageblks)
   %record (admin fm) b0admin
   %integer i, ch

   %routine write rec
      %integer i
      %for i=0,1,sizeof(b0admin)-1 %cycle; printsymbol(byteinteger(addr(b0admin)+i)); %repeat
      %for i=0,1,1023-sizeof(b0admin) %cycle; printsymbol(0); %repeat
   %end

   ch = outstream
   openoutput(1, filename); selectoutput(1)
   b0admin=0
   b0admin_free head = indexblks
   b0admin_timestamp = timestamp
   write rec
   
   b0admin=0
   %for i=1,1,indexblks-1 %cycle
      write rec
   %repeat
   
   %for i=indexblks,1,pageblks+indexblks-2 %cycle
      b0admin_free head=i+1
      write rec
   %repeat

   b0admin_free head = 0
   write rec

   close output
   selectoutput(ch)
   
%end

%integerfn pageno(%integer page id)
   %integer d,t,h
   d = page id&15; page id = page id>>4
   t = page id&15; page id = page id>>4
   h = page id&15
   %result = (h*10+t)*10+d
%end


%routine analyse db file(%string(255) filename)
   %integer ad, inlen, outlen, freecnt, busycnt, d,m,y, h,n, i, rc, fad, mad
   %record (admin fm) b0admin, bnadmin
   %halfinteger cno, oldcno, oldcell
   %halfintegerarray ind(0:512*10-1)
   rc=open cache(filename)
   stop on error(rc, "")

   inlen=1024*10; mad = addr(ind(0)); fad=0
   %cycle
      rc = F read N(nil, token1, token2, fad, inlen, outlen, byteinteger(mad), textRC)
      stop on error(rc, textRC)
      inlen=inlen-outlen; fad = fad + outlen; mad = mad + outlen
      printline("read ".itos(outlen, -1)." bytes")
   %repeatuntil inlen=0
!!!read region(file ref, 0, 1024*10, byteinteger(addr(ind(0)))) 
      
   %for i=0,1,blk0admin>>1-1 %cycle
      printstring("**** ")
   %repeat
   %for i=blk0admin>>1,1,511 %cycle
      phex4(ind(i))
      %if i&15=15 %then newline %else space
   %repeat
   newline
   read admin(0, b0admin)
   cno = b0admin_free head; freecnt=0
   printstring("Free Head ->"); write(cno, 4); newline
   %while cno#0 %cycle
      read admin(cno, bnadmin)
      oldcno = cno; cno = bnadmin_free head
      freecnt=freecnt+1
      printstring(" -> "); write(cno, 4); newline
      %if oldcno=cno %then printline("Free pointers looping") %and %exit
   %repeat
   write(freecnt, -1); printstring(" Free cells"); newline

   cno = b0admin_busy head; busycnt=0
   printstring("Busy Tail ->"); write(b0admin_busy tail, 4)
   printstring("   Busy Head ->"); write(cno, 4)
   newline
   %while cno#0 %cycle
      read admin(cno, bnadmin)
      printstring("p"); write(bnadmin_page id>>12,-1)
      printstring("."); write(pageno(bnadmin_page id),-1); printstring(": ")
      write(cno, 3)
      oldcno=cno; cno = bnadmin_fwd link; busy cnt = busy cnt+1
      
      %while bnadmin_cell ptr#0 %cycle
         printstring(","); write(bnadmin_cell ptr, -1)
         oldcell=bnadmin_cell ptr
         read admin(bnadmin_cell ptr, bnadmin)
         %if bnadmin_cell ptr = old cell %then printstring("Cell pointers looping") %and %exit
      %repeat
      printstring(" -> "); write(cno, -1)
      newline
      %if oldcno=cno %then printline("Busy pointers looping") %and %exit
   %repeat
   write(busycnt, -1); printstring(" Head cells"); newline
   readstamp(b0admin, d,m,y, h,n)
   printstring("File last altered ")
   write(d,-1); printsymbol('/'); write(m,-1); printsymbol('/'); write(y,-1);
   write(h,3); printsymbol(':'); write(n,-1); newline
   close cache
%end

%routine write admin(%integer cell, %name admin)
   %integer rc
!!   %record (admin fm) %name adm
!!   printstring("Write adm"); write(cell, 3); printstring(":")
   %if cell=0 %start
      rc = F write block(nil, token1, token2, cell*1024, blk0admin, admin, textRC)
!!!   write region(file ref, cell*1024, blk0admin, admin)
   %else
      rc = F write block(nil, token1, token2, cell*1024, blknadmin, admin, textRC)
!!!   write region(file ref, cell*1024, blknadmin, admin)
   %finish
!!   adm == record(addr(admin))
!!   write(adm_free head, 4); write(adm_busy head, 4); write(adm_busy tail, 4)
!!   newline
%end

%integerfn indexno(%integer page)
   %integer p
   !Page is supplied as a BCD number.
   !Top 4 bits channel, bottom 12 page as 3 nibbles.
   p = page&15; page=page>>4
   p = p + (page&15)*10; page=page>>4
   p = p + (page&15)*100;page=page>>4
   p = p-100 ;!Should now be an integer in the range 0-899
   p = p + ((page&15)-1)*900 ;!Include the channel number
   !5 channels = 4500 pages.
!! printline("Indexno ".itos(p,-1))
   %result=p
%end

%routine find free cell(%halfname cellno)
   %integer offset
   %halfinteger zero
   %record (admin fm) b0admin, bnadmin
   !Attempt to find a free cell (should be on the free list)
!! printline("Find free cell")
   read admin(0, b0admin)

   %if b0admin_free head#0 %start
      !It is.  Take it off the free queue and give it to the user.
      read admin(b0admin_free head, bnadmin)
      cellno = b0admin_free head; b0admin_free head = bnadmin_free head
   %else
      !Grab the first chain of pages off the busy queue, give the user the
      !first and put the rest on the free queue
      read admin(b0admin_busy head, bnadmin)
      cellno = b0admin_busy head; b0admin_busy head = bnadmin_fwd link
      !Zap the index pointer to this cell head.
      zero=0
      offset = indexno(bnadmin_page id)*2 + blk0admin
      write to cell(offset>>10, offset&1023, 2, zero)
   %finish
   write admin(0, b0admin)
!! printline("Free cell = ".itos(cellno, -1))
%end

%routine create new cell head(%integer page id, %halfname head)
   %record (admin fm) b0admin, bnadmin
   %integer offset

!! printstring("Create new cell head "); phex4(page id); newline
   !Find a free cell
   find free cell(head)

   !Locate the busy queue tail pointer.
   read admin(0, b0admin)

   %if b0admin_busy tail=0 %start
      !First cell on queue. Point head at it.
      b0admin_busy head = head
   %else
      !Add the new cell to the end of the busy queue
      read admin(b0admin_busy tail, bnadmin)
      bnadmin_fwd link=head
      write admin(b0admin_busy tail, bnadmin)
   %finish

   !Point the new cell back to the previous cell and forward to NIL
   bnadmin_cell ptr=0; bnadmin_fwd link=0; bnadmin_rev link=b0admin_busy tail
   bnadmin_page id = page id
   write admin(head, bnadmin)
   !Update the busy queue tail pointer
   b0admin_busy tail = head
   b0admin_timestamp=timestamp
   b0admin_page id=page id
   write admin(0, b0admin)
   offset = indexno(page id)*2 + blk0admin
   write to cell(offset>>10, offset&1023, 2, head)
%end

%externalintegerfn record no(%integer page id)
   %halfinteger index
   %integer offset

   offset = indexno(page id)*2 + blk0admin
   read cell(0, offset, 2, index)
!! printline("Record no(".itos(page id,-1).") = ".itos(index,-1))
   %result = index
%end

!Cache must have been OPENed first.

%routine read data(%integer cell, %name to)
   %integer rc, outlen
!! printstring("ReadData:"); write(cell, 3); newline
   rc = F read N(nil, token1, token2, cell*1024+blen, 1000, outlen, to, textRC)
%end

%externalroutine read cached page(%integer page id, address, %integername subpages)
   %integer ptr, filesize, pg
   %record (admin fm) blknadmin

   !Subpages will be 0 if the page is absent.
!! printline("Read cached page ".itos(page id,-1))
   pg=record no(page id); ptr=address; subpages=0
   %while pg#0 %cycle
      read admin(pg, blknadmin)
      read data(pg, byteinteger(ptr))
      pg = blknadmin_cell ptr; ptr=ptr+1000
      subpages=subpages+1
   %repeat
!! printline("Subpages = ".itos(subpages,-1))
%end


%routine write complete cell(%integer cell, %record (admin fm) %name admin,
%integer fromaddr)
   !This is directly equivalent to write admin followed by write data
   !but putting it like this saves filestore read/writes
   !(though at the expense of a block copy)
   %integer rc, len
   %bytearray buff(0:1023)
   move(blen, admin, buff(0))
   move(1000, byteinteger(fromaddr), buff(blen))
   len=1024
   rc = F write block(nil, token1, token2, cell*1024, len, buff(0), textRC)
!!!write region(file ref, cell*1024, 1024, buff(0))
%end

%externalroutine write cached page(%integer page id, address, subpages)
    %integer ptr,tt
    %half pg, newpg, headcell
    %record (admin fm) bnadmin
!!  printline("Write cached page ".itos(page id, -1).", ".itos(subpages,-1)." subpages")
    pg=0; newpg = record no(page id); ptr=0
    create new cell head(page id, newpg) %if newpg=0
    headcell=newpg
    tt=timestamp
    %while newpg#0 %and ptr # subpages*1000 %cycle
       !Overwrite what's there (if it's there) as far as we can
       !Read the admin info
       pg = newpg
       read admin(pg, bnadmin)
       !Change the time stamp
       bnadmin_timestamp=tt %and tt=0 %if tt#0
       write complete cell(pg, bnadmin, address+ptr)
       !overwrite the page
  
       ptr=ptr+1000
       newpg = bnadmin_cell ptr
    %repeat
  
!!  printline("adding to end") %if ptr # subpages*1000
    %while ptr # subpages * 1000 %cycle ;!We have data left to write
       !Get an unused page (or the oldest used one)
       find free cell(newpg)
       !Chain it onto the subpage list
       read admin(pg, bnadmin)
       bnadmin_cell ptr = newpg
       write admin(pg, bnadmin)
       !Write the new page admin with a null pointer to the next page
       bnadmin_cell ptr = 0
       !For subpage cells we point the forward link to the head cell
       !and the reverse link to the previous subpage cell
       bnadmin_rev link = pg
       bnadmin_fwd link = headcell
       pg = newpg
       write complete cell(pg, bnadmin, address+ptr)
       ptr=ptr+1000
    %repeat
!!  printline("Cached")
%end
     

%begin
printline("Analysing ".database file)
analyse db file(database file)
%endofprogram