{









                         (c) 1988 JaMeSoft

                             1989 LecSoft










}
Program XDOS;

const title = 'XDOS V1.1 (c) 1988 JaMeSoft & LecSoft';

type sstr = string[64];

  procedure tba(s : sstr);
    begin { tba }
    writeln('Zat'^w'Im neum'^w'Im ', s)
    end; { tba }

  function readkey : char;
    begin { readkey }
    readkey := chr(bios(2));
    end; { readkey }

  procedure hw_intro; { init vseho HW pred zacatkem }
    begin { hw intro }
    {window(1, 1, 64, 20);}
    end; { hw intro }

  procedure signon; { ohlaseni programu }
    begin { signon }
    writeln;
    writeln(title, '. HELP vyp'^w'I'^w'Se p'^w'R'^w'Ikazy');
    end; { signom }

  procedure job; { hlavni smycka }
    type
      drive = (a, b, c, d, e, unknown);
      diskop = (rd, wr);
      time = record
             hours, minutes, seconds : integer;
             end;
      date = record
             day, month, year : integer
             end;
      charset = set of char;
      secbuf = array[0..511] of byte;
      fattbl = array[0..1] of secbuf;
      fatbyted = array[0..1023] of byte;
      dir_entry = record
                  name : array[0..7] of char;
                  typ : array[0..2] of char;
                  attrib : byte;
                  reserved : array[0..9] of byte;
                  time : integer;
                  date : integer;
                  start_cluster : integer;
                  size_lo, size_hi : integer
                  end;
      disk_id = record
                jump             : array[1..3] of byte;
                name             : array[1..8] of char;
                bytes_sector : integer;
                cluster_size     : byte;
                reserved_sectors : integer;
                n_fats           : byte;
                dir_entries,
                n_sectors        : integer;
                media            : byte;
                sectors_fat,
                sectors_track,
                heads,
                hidden_sectors   : integer
                end;
      root_dir_sec = array[0..6] of secbuf;
      root_dir_entries = array[0..111] of dir_entry;

   const
      drive_letter : array[drive] of char = 'ABCDE?';
      drive_str : array[drive] of string[20] =
          ('A:', 'B:', 'C:', 'D:', 'E:', 'nedefinov'^w'Ano');
      read_only  = 1;
      hidden_file = 2;
      system_file = 4;
      volume_label = 8;
      subdir = 16;
      archive = 32;

    var
      cpmdrive, dosdrive : drive;
      path : sstr;
      cur_time : time;
      cur_date : date;
      id : disk_id;
      fat : fattbl;
      fatbyte : fatbyted absolute fat;
      directory : root_dir_sec;
      dir_entries : root_dir_entries absolute directory;
      data_clusters,
      data_area : integer;
      done : boolean;

    procedure do_cmd(cmd : sstr); { dekoduj a proved prikaz }

      function normal_str(s : sstr) : sstr; { normalizace retezce }

        function upcase_str(s : sstr) : sstr; { retezec do velkych pismen }
          var i : integer;
          begin { upcase str }
          for i := 1 to length(s) do
            s[i] := upcase(s[i]);
          upcase_str := s
          end; { upcase str }

        function remove_lead(s : sstr) : sstr; { odeber uvodni mezery }
          begin { remove_lead }
          while copy(s, 1, 1) = ' ' do
            delete(s, 1, 1);
          remove_lead := s
          end; { remove lead }

        function remove_trail(s : sstr) : sstr; { odeber mezery na konci }
          begin { remove_trail }
          if length(s) > 0
            then begin
              while copy(s, length(s), 1) = ' ' do
                delete(s, length(s), 1);
              remove_trail := s
            end
          end; { remove trail }

        begin { normal str }
        normal_str := upcase_str(remove_lead(remove_trail(s)))
        end; { normal str }

      procedure parse(var cmd, command, param : sstr); { rozdel radku na prikaz a parametr }
        var i : integer;
        begin { parse }
        param := '';
        i := pos(' ', cmd);
        if i = 0
        then command := cmd
        else begin
          command := copy(cmd, 1, pred(i));
          param := normal_str(copy(cmd, succ(i), length(cmd) - i))
          end { if }
        end; { parse }

      procedure cmd_help; { napoveda }
        var i : integer;
        begin { cmd help }
        writeln('CPMDRIVE x       volba jednotky pro soubory CP/M');
        writeln('x:               volba jednotky pro soubory DOS');
        writeln('DIR[/W] [jm'^w'Wno]  vypi'^w'S adres'^w'A'^w'R DOS diskety');
        writeln('DATE [rr-mm-dd]  vypi'^w'S, zm'^w'E'^w'N datum');
        writeln('TIME [hh:mm:ss]  vypi'^w'S, zm'^w'E'^w'N '^w'Cas');
        writeln('CPMREAD  [jm'^w'Wno] DOS: <- CP/M:jm'^w'Wno');
        writeln('CPMWRITE [jm'^w'Wno] DOS:jm'^w'Wno -> CP/M:');
        writeln('EXIT             n'^w'Avrat do CP/M');
        writeln('CLS              sma'^w'Z obrazovku');
        writeln('HELP             vypi'^w'S tento text');
        writeln('Um'^w'Im pracovat jen s kmenov'^w'Ym adres'^w'A'^w'Rem,');
        writeln('a to pouze u 360 kB MS-DOS diskety..');
        writeln('x je A a'^w'Z E, jm'^w'Wno m'^w'J'^w'Ze n'^w'Ekdy obsahovat * a ?')
        end; { cmd help }

      function n2(i : integer) : sstr;
        var s : sstr;
        begin { n2 }
        str(i, s);
        while length(s) < 2 do
          s := '0' + s;
        n2 := s
        end; { n2 }

      function dtg(param : sstr; dels : charset;
                   var a, b, c : integer;
                   ma, mb, mc : boolean) : boolean;

        function par(var n : integer) : boolean;
          var s : sstr;
              done : boolean;
              code : integer;
          begin { par }
          s := '';
          n := 0;
          done := false;
          par := false;
          param := normal_str(param);
          repeat
          if param = ''
          then done := true
          else begin
            if param[1] in dels
            then begin
              delete(param, 1, 1);
              done := true
              end { if }
            else begin
              s := s + copy(param, 1, 1);
              delete(param, 1, 1)
              end { else }
            end { else }
          until done;
          if s = ''
          then par := false
          else begin
            val(s, n, code);
            if code = 0
            then par := true
            else n := 0
            end { else }
          end; { par }

        begin { dtg }
        dtg := true;
        a := 0; b := 0; c := 0;
        if par(a)
        then if par(b)
             then if par(c)
                  then { ok }
                  else dtg := not mc
             else dtg := not mb
        else dtg := not ma
        end; { dtg }

      procedure cmd_date(param : sstr);
        const dels : charset = ['-', '/', '.'];
              must = true;
        var s_date : date;

        function date_check(var d : date) : boolean;
          const days : array[1..12] of integer =
                  (31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
          begin { date check }
          date_check := true;
          with d do begin
            if (year > 87) and (year < 99)
            then year := 1900 + year;
            if (year < 1988) or (year > 1999)
            then date_check := false
            else if not (month in [1..12])
                 then date_check := false
                 else if not (day in [1..days[month]])
                      then date_check := false
                      else if (month = 2) and (day = 29)
                           then if (year mod 4) <> 0
                                then date_check := false
            end { with }
          end; { date check }

        begin { cmd date }
        s_date := cur_date;
        if param <> ''
        then with cur_date do
          if dtg(param, dels, day, month, year, must, must, must)
          then if not date_check(cur_date)
               then begin
                 cur_date := s_date;
                 writeln('Nespravn'^w'W datum')
                 end { if }
               else
          else begin
            cur_date := s_date;
            writeln('Nespravn'^w'W datum')
            end { else }
        else with cur_date do
               writeln('Datum je ', n2(day), '-', n2(month), '-', year)
        end; { cmd date }

      procedure cmd_time(param : sstr);
        const dels : charset = ['/', '-', ':'];
              must = true;
              may = false;
        var s_time : time;

        function time_check(t : time) : boolean;
          begin { time check }
          with t do
            time_check := (hours in [0..23])
                          and (minutes in [0..59])
                          and (seconds in [0..59])
          end; { time check }

        begin { cmd time }
        s_time := cur_time;
        if param <> ''
        then with cur_time do
          if dtg(param, dels, hours, minutes, seconds, must, may, may)
          then if not time_check(cur_time)
               then begin
                 cur_time := s_time;
                 writeln('Nespr'^w'Avn'^w'Y '^w'Cas')
                 end { if }
               else
          else begin
            cur_time := s_time;
            writeln('Nespr'^w'Avn'^w'Y '^w'Cas')
            end { else }
        else with cur_time do
               writeln(''^w'cas je ', n2(hours), ':', n2(minutes), ':', n2(seconds))
        end; { cmd time }

      procedure cmd_cpmdrive(param : sstr);
        var ok : boolean;
        begin { cmd cpmdrive}
        ok := true;
        if length(param) = 2
        then if param[2] = ':'
             then delete(param, 2, 1);
        if param <> ''
        then if length(param) = 1
             then if param[1] in ['A'..'E']
                  then cpmdrive := drive(ord(param[1]) - ord('A'))
                  else ok := false
             else ok := false
        else writeln('CP/M jednotka je ', drive_str[cpmdrive]);
        if not ok
        then writeln('Nespr'^w'Avn'^w'A jednotka')
        end; { cmd cpmdrive }

      procedure cmd_dosdrive(param : sstr);
        var ok : boolean;
        begin { cmd dosdrive}
        ok := true;
        if length(param) = 2
        then if param[2] = ':'
             then delete(param, 2, 1);
        if param <> ''
        then if length(param) = 1
             then if param[1] in ['A'..'E']
                  then dosdrive := drive(ord(param[1]) - ord('A'))
                  else ok := false
             else ok := false
        else writeln('DOS jednotka je ', drive_str[dosdrive]);
        if not ok
        then writeln('Nespr'^w'Avn'^w'A jednotka')
        end; { cmd dosdrive }

      function dos_rw(dir : diskop; d : drive;
                      dos_sector : integer; var buf : secbuf) : boolean;
        var disk, track, head, sector : byte;

        function abs_rw(dir : diskop;
                        disk : drive; track, head, sector : byte;
                        var buf : secbuf) : boolean;
          var done : boolean;
              c : char;
              i, error : byte;
          begin { abs rw }
          done := false;
          repeat
            bdos(14, ord(disk));
            for i:=0 to 3 do
              begin
                bdos(26, addr(buf) + i shl 7);
                bios(9, track shl 1 + head);
                bios(10, 4 * pred(sector) + i);
                error := bios(12 + ord(dir = wr), ord(i = 3));
              end;
            abs_rw := error = 0;
            if error <> 0
            then begin
              writeln;
              write('Chyba ');
              if dir = wr
              then write('z'^w'Apisu')
              else write(''^w'Cten'^w'I');
              writeln(' na disku ', drive_str[dosdrive]);
              writeln('(Z)nova, (I)gnorovat, (A)bortovat');
              repeat c := upcase(readkey) until c in ['Z', 'I', 'A'];
              case c of
                'I' : begin done := true; abs_rw := true end;
                'A' : halt
              end { case }
              end { if }
            else done := true
          until done
          end; { abs rw }

        begin { dos rw }
        track := dos_sector div 18;
        head := (dos_sector mod 18) div 9;
        sector := (dos_sector mod 9) + 1;
        dos_rw := abs_rw(dir, d, track, head, sector, buf)
        end; { dos rw }

      procedure report(s : sstr);
        begin { report }
        writeln(s)
        end; { report }

      function find(var n : integer;
                    var entry : dir_entry;
                    pat : sstr;
                    exclude : byte) : boolean;
        var found : boolean;
            i : integer;
        begin { find }
        found := false;
        while not found and (n < id.dir_entries) do begin
          with dir_entries[n] do begin
            if name[0] = #0
            then n := id.dir_entries
            else
             if (name[0] <> #$E5) and
                (attrib and exclude = 0)
             then begin
               found := true;
               for i := 1 to 8 do
                 if pat[i] <> '?'
                 then found := found and (upcase(name[i - 1]) = pat[i]);
               for i := 1 to 3 do
                 if pat[8 + i] <> '?'
                 then found := found and (upcase(typ[i - 1]) = pat[8 + i])
               end { if }
            end; { with }
          n := n + 1
          end; { while }
        if found
        then entry := dir_entries[n - 1];
        find := found
        end; { find }

        type tname = (single, many);
        function valid_dos_name(typ : tname; var name : sstr;
                                 default : sstr) : boolean;
          const doschars : charset = ['A'..'Z', '0'..'9'];
          var fname, ftyp : sstr;
              sep : integer;
              ok : boolean;

          procedure expand(var s : sstr; n : integer);
            begin { expand }
            if s <> ''
            then if s[length(s)] = '*'
                 then begin
                   delete(s, length(s), 1);
                   while length(s) < n do
                     s := s + '?'
                   end { if }
            end; { expand }

          function check(s : sstr; c : charset) : boolean;
            var i : integer;
            begin { check }
            check := true;
            for i := 1 to length(s) do
              if not (s[i] in c)
              then check := false
            end; { check }

          begin { valid dos name }
          ok := true;
          if name = ''
          then if default <> ''
               then name := default
               else begin
                 ok := false;
                 writeln('Chyb'^w'I jm'^w'Wno')
                 end;
          if ok
          then begin
            sep := pos('.', name);
            if sep = 0
            then sep := length(name) + 1;
            fname := copy(name, 1, sep - 1);
            ftyp := copy(name, sep + 1, length(name));
            if (length(fname) > 8) or (length(ftyp) > 3)
            then ok := false;
            expand(fname, 8); expand(ftyp, 3);
            if not check(fname, doschars + ['?']) or
               not check(ftyp, doschars + ['?'])
            then ok := false;
            if typ = single
            then
              if (pos('?', fname) <> 0) or
                 (pos('?', ftyp) <> 0)
              then ok := false;
            while length(fname) < 8 do
              fname := fname + ' ';
            while length(ftyp) < 3 do
              ftyp := ftyp + ' ';
            name := fname + ftyp;
            if not ok
            then writeln('Nespravn'^w'W jm'^w'Wno "', name, '"')
            end; { if }
          valid_dos_name := ok
          end; { valid dos name }

        function fatvalue(n : integer) : integer;
          var i : integer;
          begin { fatvalue }
          i := (3 * n) div 2;
          i := fatbyte[i] + fatbyte[i + 1] shl 8;
          if odd(n)
          then fatvalue := i shr 4
          else fatvalue := i and $FFF
          end; { fatvalue }

          procedure putfat(index, value : integer);
            var i, himask, lomask : integer;
            begin { put fat }
            i := (3 * index) div 2;
            himask := $F; lomask := $FF;
            if odd(index)
            then begin
              himask := $FF;
              lomask := $F0;
              value := value shl 4
              end;
            fatbyte[i] := lo(value) and lomask or
                          fatbyte[i] and not lomask;
            fatbyte[i + 1] := hi(value) and himask or
                              fatbyte[i + 1] and not himask;
            end; { put fat }

          function rw_fat(op : diskop; d : drive; var fat : fattbl) : boolean;
            var f, i : integer;
                ok : boolean;
            begin { read fat }
            ok := true;
            with id do begin
              f := reserved_sectors + hidden_sectors;
              for i := 0 to sectors_fat - 1 do
                ok := ok and dos_rw(op, d, f + i, fat[i]);
              if op = wr
              then
                for i := 0 to sectors_fat - 1 do
                  ok := ok and dos_rw(op, d, f + i + sectors_fat, fat[i]);
              ok := ok and (fat[0,0] = media);
              rw_fat := ok
              end { with }
            end; { read fat }

          function rw_root(op : diskop; d : drive; var root : root_dir_sec) : boolean;
             var f, i : integer;
                 ok : boolean;
             begin { read root }
             ok := true;
             with id do begin
               f := reserved_sectors +
                    hidden_sectors +
                    n_fats * sectors_fat;
               data_area := f + (dir_entries * 32) div 512;
               for i := f to data_area - 1 do
                 ok := ok and dos_rw(op, d, i, root[i - f]);
               rw_root := ok;
               data_clusters := n_sectors - reserved_sectors -
                                n_fats * sectors_fat -
                                dir_entries * 32 div 512;
               data_clusters := data_clusters div 2
               end { with }
             end; { read root }

        function log_dos_disk : boolean;
          var boot : secbuf;

          function check_id(id : disk_id) : boolean;
            begin { check boot }
            with id do
              check_id:=
                (bytes_sector = 512) and
                (cluster_size = 2) and
                (reserved_sectors = 1) and
                (n_fats = 2) and
                (dir_entries = 112) and
                (n_sectors = $2D0) and
                (media = $FD) and
                (sectors_fat = 2) and
                (sectors_track = 9) and
                (heads = 2) and
                (hidden_sectors = 0)
            end; { check boot }

          begin { log dos disk }
          log_dos_disk := false;
          if not dos_rw(rd, dosdrive, 0, boot)
          then report('Chyba '^w'Cten'^w'I disku ' + drive_letter[dosdrive])
          else begin
            move(boot, id, sizeof(id));
            if not check_id(id)
            then report('Disk pravd'^w'Epodobn'^w'E nebyl form'^w'Atov'^w'An DOSem, nelze pou'^w'Z'^w'It')
            else
              if not rw_fat(rd, dosdrive, fat)
              then report('Chyba p'^w'Ri '^w'Cten'^w'I FAT !')
              else
                if not rw_root(rd, dosdrive, directory)
                then report('Chyba p'^w'Ri '^w'Cten'^w'I adres'^w'A'^w'Re !')
                else log_dos_disk := true
            end { else }
          end; { log dos disk }

      procedure cmd_dir(typ : integer; param : sstr);

        procedure list_dir(typ : integer; name : sstr);
          var free, i, n, line, col : integer;
              volume : boolean;
              entry : dir_entry;
              exclude : byte;

          function filedate(date : integer) : sstr;
            var s : sstr;
            begin { file date }
            str((1980 + (date shr 9)) mod 100, s);
            s := n2((date shr 5) and 15) + '-' + s;
            s := n2(date and 31) + '-' + s;
            filedate := s
            end; { file date }

          function longsize(l, h : integer) : sstr;
            var s : sstr;
            begin { longsize }
            s := '';
            if h = 0
            then if l >= 0
                 then str(l, s)
                 else str(65536.0 + l : 1 : 0, s)
            else if l >= 0
                 then str(65536.0 * h + l : 1 : 0, s)
                 else str(65536.0 * h + (65536.0 + l) : 1 : 0, s);
            longsize := s
            end; { longsize }

          function filetime(time : integer) : sstr;
            var h : integer;
                s : sstr;
            begin { file time }
            h := time shr 11;
            s := n2(h mod 12) + ':' + n2((time shr 5) and 63);
            if h > 11
            then s := s + 'p';
            if h = 12
            then begin
              s[1] := '1'; s[2] := '2'
              end; { if }
            filetime := s
            end; { file  time }

          procedure nl(var l : integer);

            procedure wait_key;
              var c : char;
              begin { wait key }
              while keypressed do c := readkey;
              c := readkey
              end; { wait key }

            begin { nl }
            if l < 18
            then l := l + 1
            else begin
              write('Pokra'^w'Cov'^w'An'^w'I ...');
              wait_key;
              write(^m);
              clreol;
              l := 1
              end { if }
            end; { nl }

          begin { list dir }
          exclude := hidden_file +
                     system_file +
                     volume_label;
          volume := false;
          writeln;
          write(' M'^w'Wdium v jednotce ', drive_letter[dosdrive], ' ');
          i := 0;
          while (i < id.dir_entries) and
                (dir_entries[i].name[0] <> #0) do begin
            with dir_entries[i] do
              if (attrib = volume_label) and
                 (name[0] <> #$E5)
              then begin
                writeln('je ', name, typ);
                volume := true
                end; { if }
            i := i + 1
            end; { while }
          if not volume
          then writeln(' nem'^w'A jm'^w'Wno');
          writeln(' Adres'^w'A'^w'R  ', drive_str[dosdrive], '\');
          writeln;
          i := 0; n := 0;
          line := 4;
          case typ of
            0 : begin
                while find(i, entry, name, exclude) do
                  with entry do begin
                    write(name, ' ', typ);
                    if (attrib and subdir) = 0
                    then write(longsize(size_lo, size_hi) : 9)
                    else write(' <DIR>   ');
                    write('  ', filedate(date));
                    writeln('  ', filetime(time));
                    nl(line);
                    n := n + 1
                    end { with }
                end;
            1 : begin
                col := 0;
                while find(i, entry, name, exclude) do begin
                  write(entry.name, ' ', entry.typ, '   ');
                  n := n + 1;
                  col := (col + 1) and 3;
                  if col = 0
                  then begin
                    writeln;
                    nl(line)
                    end { if }
                  end;
                if col <> 0
                then writeln
                end
          end; { case }
          write(n : 7, ' Soubor('^w'J)');
          n := data_clusters;
          for i := 2 to data_clusters + 2 do
            if fatvalue(i) >= 2
            then n := n - 1;
          writeln(longsize(n shl 10, n shr 6) : 10, ' voln'^w'Ych byt'^w'J')
          end; { list dir }

        begin { cmd dir}
        if dosdrive = unknown
        then writeln('Nev'^w'Im, kde je DOS disketa')
        else
          if valid_dos_name(many, param, '*.*')
          then
            if log_dos_disk
            then list_dir(typ, param)
        end; { cmd dir }

        function check_known : boolean;
          begin { check known }
          check_known := false;
          if dosdrive = unknown
          then writeln('Nev'^w'Im, kde je DOS disketa')
          else
            if cpmdrive = unknown
            then writeln('Nev'^w'Im, kde je CP/M disketa')
            else
              if cpmdrive = dosdrive
              then writeln('Nelze pou'^w'Z'^w'It jednu jednotku pro ob'^w'E diskety')
              else check_known := true
          end; { check known }

      type pdata = ^data;
           cl_buf_type = array[0..1] of secbuf;
           data = record
                  c_no : integer;
                  cl_buf : cl_buf_type;
                  link : pdata
                  end;

      procedure rw_cluster(op : diskop; cluster : integer;
                           var buf : cl_buf_type);
        var dos_sec, i : integer;
        begin { rw cluster }
        dos_sec := (cluster - 2) * 2 + data_area;
        for i := 0 to 1 do
          if dos_rw(op, dosdrive, dos_sec + i, buf[i]) then
        end; { rw cluster }

      procedure cmd_cpmread(param : sstr);

        procedure cpmread(param : sstr);
          var f : file;
              cpmname : sstr;
              cluster, cpmsize, entry_num, slo, shi : integer;
              dataroot : pdata;

          function alloc(var cluster : integer) : boolean;
            begin { alloc }
            while (fatvalue(cluster) <> 0) and
                  (cluster < data_clusters + 2) do
              cluster := cluster + 1;
            alloc := cluster < data_clusters + 2
            end; { alloc }

          function fcreate(var cluster : integer;
                           fname : sstr;
                           var entry_num : integer) : boolean;
            var ok : boolean;
                entry : dir_entry;
            begin { fcreate }
            entry_num := 0;
            ok := false;
            if find(entry_num, entry, fname, volume_label)
            then writeln('Soubor "', fname, '" na DOS disket'^w'E existuje !')
            else begin
              entry_num := 0;
              cluster := 2;
              repeat
                ok := dir_entries[entry_num].name[0] in [#0, #$E5];
                if not ok
                then entry_num := entry_num + 1
              until ok or (entry_num = id.dir_entries);
              if not ok
              then writeln('Pln'^w'Y adres'^w'A'^w'R DOS diskety')
              else
                if not alloc(cluster)
                then ok := false
                else
                  with dir_entries[entry_num] do begin
                    move(fname[1], name, 11);
                    start_cluster := cluster;
                    attrib := archive;
                    time := cur_time.hours shl 11 +
                            cur_time.minutes shl 5 +
                            cur_time.seconds div 2;
                    date := (cur_date.year - 1980) shl 9 +
                            cur_date.month shl 5 +
                            cur_date.day
                    end { with }
              end; { if }
            fcreate := ok
            end; { fcreate }

          procedure flush_data;
            var p, n : pdata;
            begin { flush data }
            p := dataroot;
            while p <> nil do begin
              rw_cluster(wr, p^.c_no, p^.cl_buf);
              n := p^.link;
              dispose(p);
              p := n
              end; { while }
            dataroot := nil
            end; { flush data }

          function xfer(var cluster : integer) : boolean;
            var p : pdata;
                req, next : integer;
            begin { xfer }
            req := cpmsize;
            if req > 8
            then req := 8;
            if maxavail < sizeof(data)
            then flush_data;
            if dataroot = nil
            then begin
              new(dataroot); dataroot^.link := nil;
              dataroot^.c_no := cluster;
              blockread(f, dataroot^.cl_buf, req)
              end { if }
            else begin
              p := dataroot;
              while p^.link <> nil do
                p := p^.link;
              new(p^.link);
              p := p^.link;
              p^.link := nil;
              p^.c_no := cluster;
              blockread(f, p^.cl_buf, req)
              end; { else }
            cpmsize := cpmsize - 8;
            if cpmsize < 0
            then cpmsize := 0;
            next := cluster + 1;
            if alloc(next)
            then begin
              putfat(cluster, next);
              if cpmsize = 0
              then putfat(cluster, $FFF);
              cluster := next;
              xfer := true
              end
            else xfer := false
            end; { xfer }

          procedure fclose(entry_num, slo, shi : integer);
            var i : integer;
            begin { fclose }
            with dir_entries[entry_num] do begin
              size_lo := slo;
              size_hi := shi;
              for i := 0 to 9 do
                reserved[i] := 0
              end { with }
            end; { fclose }

          var ok : boolean;
          begin { cpmread }
          dataroot := nil;
          slo := 0; shi := 0;
          cpmname := drive_letter[cpmdrive] + ':' + param;
          assign(f, cpmname);
          {$i-} reset(f); {$i+}
          if ioresult <> 0
          then writeln('Soubor "', cpmname, '" nenalezen.')
          else
            if valid_dos_name(single, param, '')
            then
              if filesize(f) = 0
              then writeln('Soubor "', cpmname, '" je pr'^w'Azdn'^w'Y.')
              else
                if fcreate(cluster, param, entry_num)
                then begin
                  cpmsize := filesize(f);
                  slo := cpmsize;
                  repeat
                    ok := xfer(cluster)
                  until (cpmsize = 0) or not ok;
                  if not ok
                  then writeln('DOS disk je pln'^w'Y.')
                  else begin
                    flush_data;
                    shi := slo shr 9;
                    slo := slo shl 7;
                    fclose(entry_num, slo, shi);
                    if not rw_fat(wr, dosdrive, fat)
                    then write('Chyba p'^w'Ri z'^w'Apisu FAT DOS diskety !!!')
                    else if not rw_root(wr, dosdrive, directory)
                         then write('Chyba p'^w'Ri z'^w'Apisu adres'^w'A'^w'Re DOS diskety !!!')
                  end { if }
                end { if }
          end; { cpmread }

        begin { cmd cpmread}
        if check_known
        then
          if log_dos_disk
          then cpmread(param)
        end; { cmd cpmread }

      procedure cmd_cpmwrite(param : sstr);

        procedure cpmwrite(param : sstr);
          var c, n, i, j : integer;
              short_name : sstr;
              entry : dir_entry;
              f : file;
              dataroot : pdata;

          procedure flush_data;
            var p, n : pdata;
            begin { flush data }
            p := dataroot;
            while p <> nil do begin
              blockwrite(f, p^.cl_buf, 8);
              n := p^.link;
              dispose(p);
              p := n
              end; { while }
            dataroot := nil
            end; { flush data }

          procedure xfer(cluster : integer);
            var p : pdata;
            begin { xfer }
            if maxavail < sizeof(data)
            then flush_data;
            if dataroot = nil
            then begin
              new(dataroot); dataroot^.link := nil;
              rw_cluster(rd, cluster, dataroot^.cl_buf)
              end { if }
            else begin
              p := dataroot;
              while p^.link <> nil do
                p := p^.link;
              new(p^.link);
              p := p^.link;
              p^.link := nil;
              rw_cluster(rd, cluster, p^.cl_buf)
              end { else }
            end; { xfer }

          begin { cpmwrite }
          i := 0;
          n := 0;
          while find(i, entry, param, hidden_file + system_file +
                     volume_label + subdir) do
            with entry do begin
              short_name := ''; j := 0;
              while (j < 8) and (name[j] <> ' ') do
                begin
                  short_name := short_name + name[j];
                  j := succ(j);
                end;
              write(short_name, ' ', typ);
              dataroot := nil; bdos(13);
              assign(f, drive_str[cpmdrive] + short_name + '.' + typ);
              rewrite(f);
              c := start_cluster;
              while (c >= 2) and (c <= $FEF) do begin
                xfer(c);
                c := fatvalue(c);
                end; { while }
              flush_data;
              close(f);
              n := n + 1;
              writeln;
            end;
          writeln;
          writeln('      Zkop'^w'Irov'^w'Ano ', n, ' soubor('^w'J)');
          end; { cpmwrite }

        begin { cmd cpmwrite }
        if check_known
        then
          if valid_dos_name(many, param, '')
          then
            if log_dos_disk
            then cpmwrite(param)
        end; { cmd cpmwrite }

      var command, param : sstr;
      begin { do cmd }
      cmd := normal_str(cmd);
      parse(cmd, command, param);
      if command = ''
      then
      else if (length(command) = 2) and
              (command[1] in ['A'..'Z']) and
              (command[2] = ':')
           then cmd_dosdrive(command)
      else if (command = 'HELP') or
              (command = '?')
           then cmd_help
      else if command = 'EXIT'
           then done := true
      else if command = 'CLS'
           then clrscr
      else if command = 'DATE'
           then cmd_date(param)
      else if command = 'TIME'
           then cmd_time(param)
      else if command = 'CPMDRIVE'
           then cmd_cpmdrive(param)
      else if command = 'CPMWRITE'
           then cmd_cpmwrite(param)
      else if command = 'CPMREAD'
           then cmd_cpmread(param)
      else if command = 'DIR'
           then cmd_dir(0, param)
      else if command = 'DIR/W'
           then cmd_dir(1, param)
      else
        writeln('Nezn'^w'Am'^w'Y p'^w'R'^w'Ikaz "', command, '", HELP vyp'^w'I'^w'Se p'^w'R'^w'Ikazy')
      end; { do cmd }

    function get_cmd : sstr;
      var cmd : sstr;
      begin { get cmd }
      write('(', drive_letter[cpmdrive], ':) ');
      write(drive_letter[dosdrive], ':', path, '>');
      readln(cmd);
      get_cmd := cmd
      end; { get cmd }

    begin { job }
    cpmdrive := unknown;
    dosdrive := unknown;
    path := '\';
    with cur_time do begin
      hours := 0; minutes := 0; seconds := 0
      end; { with }
    with cur_date do begin
      day := 1; month := 1; year := 1988
      end; { with }
    done := false;
    repeat
      do_cmd(get_cmd)
    until done
    end; { job }

  procedure hw_exit; { init hw po skonceni }
    begin { hw exit }
    end; { hw exit }

  begin { xdos }
  hw_intro;
  signon;
  job;
  hw_exit
  end. { xdos }
