CP/M/CPM_CDROM.iso/beehive/bbs/rosuncr.arc/ROSKMS.INC

Text File | 1991-08-11 | 11KB | 357 lines

{ ROSKMS.INC - Remote Operating System Kernel - Miscellaneous routines  }

{ 09dec87 wb - access section file data from disk instead of heap to
  reduce ram requirements.
  07nov87 wb - Added exist function for new file find command.
  11nov86 wb - Modified diskfree function & hide_release procedure for
               use with Turbodos.  }

function trim(st: StrStd): StrStd;
{ Remove leading and trailing blanks }
  var
   i, j: integer;
  begin
    i := 1;
    j := length(st);
    while (st[i] = ' ') and (i <= j) do
      i := succ(i);
    while (st[j] = ' ') and (j >= i) do
      j := pred(j);
    trim := copy(st, i, succ(j - i))
  end;

function exist(filen: FileName): boolean;
{ Return true if file exists }
  var f: file;
  begin
    {$i-}
    assign(f,filen);
    reset(f);
    {$i+}
    if ioresult <> 0 then exist:=false
    else exist:=true;
  end;

procedure SetSect(Drive, User: integer);
{ Set to file section }
  begin
    BDOS(seldrive, Drive);
    BDOS(getseluser, User)
  end;

procedure FindSect(req: FileName; var Drive, User: integer; var found: boolean);
{ Find file section from requested name }
  begin
    reset(sect_file);
    while ((req <> trim(SName)) or (SDrive = ' ')) and (not eof(sect_file)) do
      readln(sect_file, SDrive, SUser, SAccs, SName, SDesc);
    found := ((req = trim(SName)) and (cold or (user_rec.access >= SAccs)));
    if found
      then
        begin
          Drive := ord(SDrive)-ord('A');
          User := SUser
        end
  end;

{
  var
    this: SectPtr;
  begin
    this := SectBase;
    while (req <> this^.SectName) and (this <> nil) do
      this := this^.next;
    found := ((req = this^.SectName) and (cold or (user_rec.access >= this^.SectAccs)));
    if found
      then
        begin
          Drive := this^.SectDrive;
          User := this^.SectUser
        end
  end;
}

function diskfree: integer;
{ Compute amount of free disk space on current drive
  with Turbodos get disk allocation T-function #19 }
  var
    blksiz,drive : byte;
    size,freblks,i : integer;
  begin
    drive := bdos(25);  { get current drive with C-function #25 }
    inline              { use Tdos call to get disk allocation }
      ($0E/$13/         { ld c,19         ;c= get disk allocation T-function }
       $3A/drive/       { ld a,drive      ;a= drive }
       $5F/             { ld e,a          ;e= drive }
       $CD/$50/00/      { call 50h        ;perform t-function }
       $ED/$53/freblks/ { ld (freblks),de ;save free blocks }
       $E6/$07/         { and 7           ;mask low 3 bits }
       $32/blksiz);     { ld (blksiz),a   ;save block size }
    size := freblks;
    for i := 1 to blksiz-3 do  { 3=1k, 4=2k, 5=4k, etc.. }
      size := size*2;
    diskfree := size
  end;

procedure hide_release(name: FileName; status: record_status);
{ Hide or release Turbodos file using BDOS set attributes funct #30 }
  var
    fcbadr,t2,i : integer;
    temp_file: file;
  begin
    Assign(temp_file,name);
    fcbadr := addr(temp_file)+12;     { i= addr of cp/m fcb }
    t2 := fcbadr+10;                  { t2= addr of 2nd file type char }
    if status = public
      then mem[t2] := $7f and mem[t2] { turn $SYS bit off }
      else mem[t2] := $80 or mem[t2]; { turn $SYS bit on }
    if bdos(30,fcbadr) <> 0           { set file attributes }
      then writeln(USR, name, ' not found.')
  end;

function min(x, y: integer): integer;
{ Return minimum of two integers }
  begin
    if x < y
      then min := x
      else min := y
  end;

function max(x, y: integer): integer;
{ Return greater of two integers }
  begin
    if x > y
      then max := x
      else max := y
  end;


function pad(st: StrStd; i: integer): StrStd;
{ Pad string with spaces to length of i }
  begin
    while length(st) < i do
      st := st + ' ';
    pad := st
  end;

function intstr(n, w: integer): Str10;
{ Return a string value (width 'w')for the input integer ('n') }
  var
    st: Str10;
  begin
    str(n:w, st);
    intstr := st
  end;

function strint(st: Str10): integer;
{ Convert string to integer }
  var
    x, code: integer;
  begin
    if st[1] = '+'
      then delete(st, 1, 1);
    if st = ''
      then code := 1
      else val(st, x, code);
    if code = 0
      then strint := x
      else strint := 0                      { Error, return with 0 }
  end;

function zeller(day, month, year: integer): integer;
{ Compute the day of the week using Zeller's Congruence }
  var
    century: integer;
  begin
    if month > 2
      then month := month - 2
      else
        begin
          month := month + 10;
          year := pred(year)
        end;
    century := year div 100;
    year := year mod 100;
    zeller := (day - 1 + ((13 * month - 1) div 5) + (5 * year div 4) +
              century div 4 - 2 * century + 1) mod 7
  end;

function FormTAD(t: tad_array): StrTAD;
{ Build printable string of current time and date }
  const
    day: array [0..6] of string[6] =
      ('Sun','Mon','Tues','Wednes','Thurs','Fri','Satur');
    month: array [1..12] of string[3] =
      ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
  var
    i: integer;
    line: StrTAD;
  begin
    if (t[1] in [0..59]) and (t[2] in [0..23])
      then line := intstr(t[2], 2) + ':' + intstr(t[1], 2)
      else line := '';
    for i:= 1 to length(line) do
      if line[i] = ' '
        then line[i]:= '0';
    if (t[3] in [1..31]) and (t[4] in [1..12]) and (t[5] in [0..99])
      then FormTAD :=
        line + '  ' +
        day[zeller(t[3], t[4], 1900 + t[5])] + 'day  ' +
        intstr(t[3], 2) + '-' + month[t[4]] + '-' + intstr(t[5], 2)
      else FormTAD := 'No Date'
  end;

procedure send_time(size: integer; var mm, ss: integer);
{ Compute the file transfer time }
  var
    tr_time: real;
  begin
    tr_time := size * 23.5 / rate;          { Factor is empirically derived  }
    mm := trunc(tr_time);
    ss := round(60.0 * frac(tr_time))
  end;

procedure timer(var time_on, time_left: integer);
{ Compute the time on and the time remaining to the current user }
  var
    t: tad_array;
  begin
    GetTAD(t);
    time_on := 60 * (t[2] - login_t[2]) + t[1] - login_t[1];
    if time_on < 0
      then time_on := time_on + 1440;
    time_left := user_rec.limit + extra_time - time_on
  end;

procedure log(activity: byte; text: FileName);
{ Update log file }
  begin
    seek(logr_file, FileSize(logr_file));
    GetTAD(logr_rec.date);
    logr_rec.action := activity;
    logr_rec.user := user_loc;
    logr_rec.text := text;
    write(logr_file, logr_rec)
  end;

procedure mesg_insert(TypMsg: byte);
{ Insert message into linked list }
  var
    this: MesgPtr;
  begin
    new(this);
    if MesgBase = nil
      then MesgBase := this
      else MesgLast^.next := this;
    MesgLast := this;
    MesgLast^.MesgNo := summ_rec.num;
    MesgLast^.SummLoc := pred(FilePos(summ_file));
    MesgLast^.TypMsg := TypMsg;
    MesgLast^.next := nil
  end;

procedure InsertFile(fname: name_array; index, size: integer;
                     var entries, total: integer; var first: FilePtr);
{ Insert a new file name into an alphabetic list }
  var
    space: integer;
    f,                                      { File name entry being created }
    this, last: FilePtr;                    { Followers for insertion }
    fn: FileName;
  begin
    fn := '           ';                    { Initialize string }
    move(fname, fn[1], 11);                 { Move name into place }
    insert('.', fn, 9);
    last := nil;
    this := first;
    while (this <> nil) and (this^.fname < fn) do
      begin
        last := this;
        this := this^.next
      end;
    space := size shr 3;
    if (size mod 8) <> 0
      then space := succ(space);
    if this^.fname <> fn
      then
        begin
          entries := succ(entries);
          total := total + space;
          new(f);
          f^.fname := fn;
          f^.index := index;
          f^.fsize := size;
          f^.next  := this;
          if last = nil
            then first := f
            else last^.next := f
        end
    else if (this^.fname = fn) and (this^.fsize < size)
      then
        begin
          total := total + space;
          space := this^.fsize shr 3;
          if (this^.fsize mod 8) <> 0
            then space := succ(space);
          total := total - space;
          this^.fsize := size
        end
  end;

{ Notes on updcrc:

   Purists that want ROS to be written COMPLETELY in Pascal, should use the
   Pascal version, but it is slower than the inline code version.  The inline
   code version is, of course, Z-80 specific, but it is MUCH faster.

   The two procedures are functionally equivalent - simply comment out the
   procedure you don't want to use.
}

(*
procedure updcrc(var crc: integer; acc: integer);
{ Update CRC with passed value }
    var
      carry: boolean;
      i: integer;
    begin
      for i := 1 to 8 do
        begin
          carry := ((crc and $8000) <> 0);
          crc := crc shl 1;
          if (acc and $0080) <> 0
            then crc := succ(crc);
          acc := acc shl 1;
          if carry
            then crc := crc xor $1021       { Use $8005 for CRC-16 }
        end
    end;
*)

procedure updcrc(var crc: integer; acc: integer);
{ Update CRC with passed value }
  begin
    inline($2A/crc/       {         LD      HL,(crc)    ; point to crc    }
           $5E/           {         LD      E,(HL)      ; put crc into DE }
           $23/           {         INC     HL          ;                 }
           $56/           {         LD      D,(HL)      ;                 }
           $EB/           {         EX      DE,HL       ; put it into HL  }
           $ED/$4B/acc/   {         LD      BC,(acc)    ; get acc into C  }
           $06/$08/       {         LD      B,8         ; shift 8 times   }
           $CB/$01/       { UPDLP:  RLC     C           ; shift input     }
           $ED/$6A/       {         ADC     HL,HL       ; shift crc       }
           $30/$08/       {         JR      NC,SKIPIT   ; jump if no carry}
           $7C/           {         LD      A,H         ; xor with $1021  }
           $EE/$10/       {         XOR     10H         ; use $8005 for   }
           $67/           {         LD      H,A         ;   CRC-16        }
           $7D/           {         LD      A,L         ;                 }
           $EE/$21/       {         XOR     21H         ;                 }
           $6F/           {         LD      L,A         ;                 }
           $10/$F0/       { SKIPIT: DJNZ    UPDLP       ; done?           }
           $EB/           {         EX      DE,HL       ; result to DE    }
           $72/           {         LD      (HL),E      ; then into       }
           $2B/           {         DEC     HL          ;   into          }
           $73)           {         LD      (HL),D      ;     memory      }
end;