(* ------------------- VERSION 10 vom 17.04.86 ------------------- *)
PACKET archive manager DEFINES                 (* Autor: J.Liedtke*)
 
      archive manager ,
      provide channel :



LET std archive channel  = 31 ,

    ack              = 0 ,
    nak              = 1 ,
    error nak        = 2 ,
    second phase ack = 5 ,
    false code       = 6 ,
 
    fetch code       = 11 ,
    save code        = 12 ,
    exists code      = 13 ,
    erase code       = 14 ,
    list code        = 15 ,
    all code         = 17 ,
    clear code       = 18 ,
    reserve code     = 19 ,
    free code        = 20 ,
    check read code  = 22 ,
    format code      = 23 ,

    read error       = 92 ,
 
    max files = 200 ,
 
    start of volume = 1000 ,
    end of volume = 1 ,
    file header   = 3 , 

    number of header blocks = 2 ,
 
    quote         = """" ,
    dummy name    = "-" ,
    dummy date    = "        " ,

 
    HEADER = STRUCT (TEXT name, date, INT type, TEXT password) ;


BOUND STRUCT (TEXT name, pass) VAR msg ;

INT VAR archive channel := std archive channel ;

TASK VAR archive owner := niltask ,
         order task ;
TEXT VAR archive name := "" , write stamp ;

REAL VAR last access time := 0.0 ;

BOOL VAR was already write access ;


DATASPACE VAR header space := nilspace ;
BOUND HEADER VAR header ;

TEXT VAR file name := "" ;

LET invalid   = 0 ,
    read only = 1 ,
    valid     = 2 ;

LET accept read errors = TRUE ,
    ignore read errors = FALSE ;


INT VAR directory state := invalid ;

THESAURUS VAR directory ;
INT VAR dir index ;

INT VAR archive size ;

INT VAR end of volume block ;
ROW max files INT VAR header block ;
ROW max files TEXT VAR header date ;


 
PROC provide channel (INT CONST channel) :

  archive channel := channel

ENDPROC provide channel ;

PROC archive manager :

  archive manager (archive channel)

ENDPROC archive manager ;

PROC archive manager (INT CONST channel) :

  archive channel := channel ;
  task password ("-") ;
  global manager 
     (PROC (DATASPACE VAR, INT CONST, INT CONST, TASK CONST) archive manager)

ENDPROC archive manager ;

PROC archive manager (DATASPACE VAR ds, INT CONST order, phase,
                      TASK CONST task) :


  enable stop ;
  order task := task ;
  msg := ds ;
  SELECT order OF
    CASE fetch code       : fetch file
    CASE save code        : save file
    CASE exists code      : exists file
    CASE erase code       : erase file
    CASE list code        : list (ds); manager ok (ds)
    CASE all code         : deliver directory
    CASE clear code,
         format code      : clear or format
    CASE reserve code     : reserve 
    CASE free code        : free
    CASE check read code  : check
    OTHERWISE errorstop (name (myself) + ": unbekannter Auftrag")
  ENDSELECT .

deliver directory :
  access archive ;
  BOUND THESAURUS VAR all names := ds ;
  all names := directory ;
  WHILE all names CONTAINS dummy name REP
    delete (all names, dummy name, dir index)
  PER ;
  manager ok (ds) .

clear or format :
  IF NOT (order task = archive owner)
    THEN errorstop ("Archiv nicht angemeldet")
  ELIF phase = 1
    THEN ask for erase all
  ELSE   directory state := invalid ;
         IF order <> clear code
           THEN format archive (specification) ;
                archive size := archive blocks
         FI ;
         rewind ;
         write header (archive name, text (clock(1),13,1), start of volume);
         write end of volume ;
         manager ok (ds)
  FI .

ask for erase all :
  IF order = format code AND specification > 3
    THEN errorstop ("ungueltiger Format-Code")
  FI ;
  look at volume header ;
  IF header.name <> ""
    THEN IF order = clear code
           THEN manager question ("Archiv """+header.name+""" loeschen", order task) 
           ELSE manager question ("Archiv """+header.name+""" formatieren", order task) 
         FI 
    ELSE IF order = clear code
           THEN manager question ("Archiv initialisieren", order task) 
           ELSE manager question ("Archiv formatieren", order task)
         FI
  FI .

specification :
  int (msg.name) .

reserve :
  IF reserve or free permitted
     THEN continue archive channel;
          disable stop ;
          directory state := invalid ;
          archive owner := order task ;
          archive name := msg.name ;
          manager ok (ds)
     ELSE errorstop ("Archiv wird von Task """+name(archive owner)+""" benutzt")
  FI .

continue archive channel :
  continue channel (archive channel) .

free :
  IF reserve or free permitted 
    THEN archive owner := niltask ;
         break (quiet) ;
         manager ok (ds)
    ELSE manager message ("Archiv nicht angemeldet", order task)
  FI.

reserve or free permitted :
     order task = archive owner OR last access more than five minutes ago
     OR archive owner = niltask OR NOT
     (exists (archive owner) OR station (archive owner) <> station (myself)) .
 
last access more than five minutes ago :
     abs (last access time - clock (1)) > 300.0 .

fetch file :
  access archive ;
  access file (msg.name) ;
  IF no read error remarked
    THEN disable stop ;
         fetch (ds, accept read errors) ;
         IF read error occurred
           THEN remark read error
         FI ;
         enable stop
    ELSE fetch (ds, ignore read errors)
  FI ;
  manager ok (ds) .

no read error remarked :
  pos (file name, " mit Lesefehler") = 0 .

read error occurred :
  is error AND error code = read error .

remark read error :
  dir index := link (directory, file name) ;
  REP
    file name CAT " mit Lesefehler" ;
  UNTIL NOT (directory CONTAINS file name) PER ;
  IF LENGTH file name < 100
    THEN rename (directory, dir index, file name)
  FI .

save file :
  IF phase = 1
    THEN access archive ;
         access file (msg.name) ;
         IF file in directory
           THEN manager question (""""+file name +""" ueberschreiben", order task)
           ELSE send (order task, second phase ack, ds)
         FI
    ELSE access archive ;
         access file (file name) ;
         erase ;
         save (ds) ;
         forget (ds) ;
         ds := nilspace ;
         manager ok (ds)
  FI .

exists file :
  access archive ;
  access file (msg.name) ;
  IF file in directory
    THEN manager ok (ds)
    ELSE send (order task, false code, ds)
  FI .

erase file :
  access archive ;
  access file (msg.name) ;
  IF file in directory
    THEN IF phase = 1
           THEN manager question (""""+file name+""" loeschen", order task)
           ELSE erase ; manager ok (ds)
         FI
    ELSE manager message ("gibt es nicht", order task)
  FI .

check :
  access archive ;
  access file (msg.name) ;
  IF file in directory
    THEN position to file ;
         disable stop ;
         check read ;
         IF is error
           THEN clear error; error ("fehlerhaft")
           ELSE last access time := clock (1) ;
                manager message ("""" + file name + """ ohne Fehler gelesen", order task)
         FI
    ELSE error ("gibt es nicht")
  FI .

file in directory :  dir index > 0 .

position to file :
  seek (header block (dir index) + number of header blocks) .

ENDPROC archive manager ;

PROC manager ok (DATASPACE VAR ds) :

  send (order task, ack, ds) ;
  last access time := clock (1) .

ENDPROC manager ok ;

PROC access archive :
 
  IF NOT (order task = archive owner)
    THEN errorstop ("Archiv nicht angemeldet")
  ELIF directory state = invalid
    THEN open archive
  ELIF last access more than two seconds ago
    THEN check volume name ;
         new open if somebody changed medium
  FI .

last access more than two seconds ago :
  abs (clock (1) - last access time) > 2.0 .

new open if somebody changed medium :
  IF header.date <> write stamp
    THEN directory state := invalid ;
         access archive
  FI .

open archive :
  directory state := invalid ;
  check volume name ;
  write stamp := header.date ;
  was already write access := FALSE ;
  read directory ;
  make directory valid if no read errors occurred .

read directory :
  directory := empty thesaurus ;
  rewind ;
  get next header ;
  WHILE header.type = file header REP
    IF directory CONTAINS header.name
      THEN rename (directory, header.name, dummy name)
    FI ;
    insert (directory, header.name, dir index) ;
    header block (dir index) := end of volume block ;
    header date (dir index)  := header.date ;
    get next header ;
  PER .

make directory valid if no read errors occurred :
  IF directory state = invalid
    THEN directory state := valid
  FI .

ENDPROC access archive ;

PROC access file (TEXT CONST name) :

  file name := name ;
  dir index := link (directory, file name) .

ENDPROC access file ;


PROC check volume name :

  disable stop ;
  archive size := archive blocks ;
  read volume header ;
  IF header.type <> start of volume
    THEN simulate header (start of volume, "?????")
  ELIF header.name <> archive name
    THEN errorstop ("Archiv heisst """ + header.name + """")
  FI .

read volume header :
  rewind ;
  read header ;
  IF is error AND error code = read error
    THEN clear error ;
         simulate header (start of volume, "?????")
  FI .

ENDPROC check volume name ;

PROC get next header :

  disable stop ;
  skip dataspace ;
  IF NOT is error
    THEN read header
  FI ;
  IF is error
    THEN clear error ;
         directory state := read only ;
         search header
  FI ;
  end of volume block := block number - number of header blocks .

search header :
  INT VAR ds pages ;
  search dataspace (ds pages) ;
  IF ds pages < 0
    THEN simulate header (end of volume, "")
  ELIF NOT is header space
    THEN simulate header (file header, "????? " + text (block number))
  FI .

is header space :
  IF ds pages <> 1
    THEN FALSE
    ELSE remember position ;
         read header ;
         IF read error occurred
           THEN clear error; back to old position; FALSE
         ELIF header format looks ok
           THEN TRUE
           ELSE back to old position ; FALSE
         FI
  FI .

read error occurred :
  is error CAND error code = read error .

header format looks ok :
  header.type = file header OR header.type = end of volume .

remember position :
  INT CONST old block nr := block number .

back to old position :
  seek (old block nr) .

ENDPROC get next header ;

PROC fetch (DATASPACE VAR ds, BOOL CONST error accept):

  enable stop ;
  IF file name <> dummy name
    THEN fetch from archive
    ELSE error ("Name unzulaessig")
  FI .

fetch from archive :
  IF file in directory
    THEN position to file ;
         read (ds, 30000, error accept)
  ELIF directory state = read only
    THEN error ("gibt es nicht (oder Lesefehler)")
    ELSE error ("gibt es nicht")
  FI .

position to file :
  seek (header block (dir index) + number of header blocks) .

file in directory :  dir index > 0 .
 
ENDPROC fetch ;

PROC erase :

  IF directory state = read only
    THEN errorstop ("'save'/'erase' wegen Lesefehler verboten")
    ELSE update write stamp if first write access ;
         erase archive
  FI .

update write stamp if first write access :
  IF NOT was already write access 
    THEN rewind ;
         write stamp := text (clock (1), 13, 1) ;
         write header (archive name, write stamp, start of volume) ;
         was already write access := TRUE
  FI .

erase archive :
  IF file in directory
    THEN IF is last file of archive
           THEN cut off all erased files
           ELSE rename to dummy
         FI
  FI .

file in directory :         dir index > 0 .

is last file of archive :   dir index = highest entry (directory) .

cut off all erased files :
  directory state := invalid ;
  REP
    delete (directory, dir index) ;
    dir index DECR 1
  UNTIL dir index = 0 COR name (directory, dir index) <> dummy name PER ;
  behind last valid file ;
  write end of volume ;
  directory state := valid .

behind last valid file :
  seek (header block (dir index + 1)) ;
  end of volume block := block number .

rename to dummy :
    directory state := invalid ;
    to file header ;
    read header ;
    to file header ;
    header.name := dummy name ;
    header.date := dummy date ;
    write (header space) ;
    rename (directory, file name, dummy name) ;
    header date (dir index) := dummy date ;
    directory state := valid .

to file header :
  seek (header block (dir index)) .

ENDPROC erase ;

PROC save (DATASPACE VAR ds) :

  IF file name <> dummy name
    THEN save to archive
    ELSE error ("Name unzulaessig")
  FI .

save to archive :
  IF file too large OR highest entry (directory) >= max files
    THEN error ( "kann nicht geschrieben werden (Archiv voll)")
    ELSE write new file
  FI .

file too large :
  end of volume block + ds pages (ds) + 5 > archive size .

write new file :
  seek (end of volume block) ;
  disable stop ;
  write file (ds) ;
  IF is error
    THEN seek (end of volume block)
    ELSE insert (directory, file name, dir index) ;
         remember begin of header block ;
         remember date
  FI ;
  write end of volume .

remember begin of header block :
  header block (dir index) := end of volume block .

remember date :
  header date (dir index) := date .

ENDPROC save ;

PROC write file (DATASPACE CONST ds) :

  enable stop ;
  write header (file name, date, file header) ;
  write (ds) 

ENDPROC write file ;

PROC write end of volume :

  disable stop ;
  end of volume block := block number ;
  write header ("", "", end of volume)

ENDPROC write end of volume ;

PROC write header (TEXT CONST name, date, INT CONST header type) :

  forget (header space) ;
  header space := nilspace ;
  header := header space ;

  header.name := subtext (name,1,100) ;
  header.date := date ;
  header.type := header type ;

  write (header space) 

ENDPROC write header ;

PROC read header :

  IF archive size > 0
    THEN forget (header space) ;
         header space := nilspace ;
         read (header space, 1, accept read errors) ;
         header := header space
    ELSE errorstop ("Lesen unmoeglich (Archiv)")
  FI .

ENDPROC read header ;

PROC simulate header (INT CONST type, TEXT CONST name) :

  forget (header space) ;
  header space := nilspace ;
  header := header space ;
  header.name := name ;
  header.date := "??.??.??" ;
  header.type := type ;
  header.password := ""

ENDPROC simulate header ;

PROC look at volume header :

  rewind ;
  archive size := archive blocks ;
  forget (header space) ;
  header space := nilspace ;
  INT VAR return code ;
  read block (header space, 1, 1, return code) ;
  header := header space ;
  disable stop ;
  IF return code <> 0 OR
     LENGTH header.name < 0 OR LENGTH header.name > 100 OR is error
    THEN header.name := "" ;
         clear error
  FI

ENDPROC look at volume header ;

PROC list (DATASPACE VAR ds) :

  access archive ;
  open list file ;
  INT VAR file number := 0 ;
  get (directory, file name, file number) ;
  WHILE file number > 0 REP
    generate list line ;
    get (directory, file name, file number)
  PER ;
  IF directory state = read only
    THEN putline (list file, "Lesefehler: Evtl. fehlen Eintraege")
  FI ;
  write list head .

open list file :
  forget (ds) ;
  ds := nilspace ;
  FILE VAR list file := sequential file (output, ds) ;
  putline (list file, "") .

generate list line :
  write (list file, header date (file number)) ;
  write (list file, text (file blocks DIV 2, 5)) ;
  write (list file, " K  ") ;
  IF file name = dummy name
    THEN write (list file, dummy name)
    ELSE write (list file, quote) ;
         write (list file, file name) ;
         write (list file, quote)
  FI ;
  line (list file) .

file blocks :
  IF file number < highest entry (directory)
    THEN header block (file number+1) - header block (file number)
    ELSE end of volume block - header block (file number)
  FI .

write list head :                                      (* wk 22.08.85 *)
  headline (list file, archive name +
            " (" + used + " K belegt von " + text (archive size DIV 2) + " K)") .

used :  text ((end of volume block + 3) DIV 2) .

ENDPROC list ;

PROC error (TEXT CONST error msg) :

  errorstop ("""" + file name + """ " + error msg)
 
ENDPROC error ;

ENDPACKET archive manager ;