{---------------------------------------------------------------------------}
                            PROGRAM CMDMAK;
{                           ===============	

            Gets disk contents catalogue of current drive.
            Detects entries with all attributes from all user areas.
            Catalogue will be written as PSEND.CMF to disk A.
            This version for CP/M V 2.2 or equivalent DOS.
            (Written Oct 17th, 83, by H.-G. Joepgen, D-7000 Stuttgart 40).

            (Adapted running on TURBO Pascal by W.Cirsovius).

            Compilers: TURBO Pascal V 3.1.

            Program dedicated to public domain by MC  Magazine, Munich.
}
const siz    =  256;                         {names array size: 1..siz}

type styp    =  string [12];                 {file name goes here}
     ptr     =  ^integer;                    {var param to dos call}
     fcbtyp  =  array [0..32] of Byte;       {cp/m file control block}
     artyp   =  array [1..11] of char;       {holds returned file name}
     enttyp  = record                        {this struct returned by cp/m}
                 topfield: byte;
                 nam:      artyp;
                 exfield:  byte;
                 tail:     array [1..19] of char
               end;
     buftyp  = array  [0..3] of enttyp;      {dma buffer holds four entries}

var f:        text;                          {CMF file to be written}
    c:        char;                          {holds user answer}
    usernum:  0..31;                         {returned by cp/m}
    firstent: boolean;                       {first entry searched/found}
    lastent:  boolean;                       {last entry found: end flag}
    fcb:      fcbtyp;                        {here we build search fcblock}
    n,                                       {multi purposes counter}
    scount,                                  {index to array sar: file names}
    funct:    integer;                       {function selector to dos call}
    buffer:   buftyp;                        {cp/m copies dir records here}
    s:        styp;                          {current file nane found}
    s1:       string [8];                    {praefix part of file name}
    s2:       string [3];                    {suffix part oft file name}
    sar:      array [1.. siz] of styp;       {found naies stored here}

procedure clrbit(var ch:char; bit:integer);
var i,mask:integer;
begin
    i:=0;
    mask:=1;
    while i<>bit do
    begin
      mask:=mask*2;
      i:=i+1;
    end;
    mask:=255-mask;
    ch:=char(ord(ch) and mask);
end;

procedure getput;                            {fill sar with valid entries}
var i: 1.. 11;                               {index; ISO says must be local}
begin
    if firstent                              {here we are looking for 1st}
    then begin writeln;
           fillchar ( fcb [ 0], 12, '?');          {prepare 'scan all'}
           fillchar ( fcb [12], 20, chr (0));
           funct := 17;                            {search for first funct}
           firstent := false; scount := 0;         {init loop variables}
           n := BDOS (26, addr (buffer))           {set dma address }
         end
    else begin funct := 18;                        {search for next funct}
               fcb [14] := 0                       {fcb byte s2}
         end;

 n := BDOS (funct, addr (fcb));                {perform search}
 lastent := (n > 3);                           {searching failed}

   if lastent then exit;                       {this entry unvalid}
   if buffer [n].topfield = $e5 then exit;     {erased entry encountered}
   if buffer [n].exfield <> 0 then exit;       {this is not extent zero}

 usernum := buffer [n].topfield;
 s [0] := chr (11);                            {set string length byte}
 move (buffer [n].nam [1], s [1], 11);         {copy naie to string s}
   for i:= 1 to 11 do clrbit (s [i], 7);       {reset attribute bits}
 s1:= copy (s, 1, 8);                          {get praefix part of name}
 s2:= copy (s, 9, 3);                          {get suffix part of name}

 insert ('.', s, 9);                           {get file name period}
 n := pos (' ', s);                            {let's remove blanks}
   if n > 0 then repeat delete (s, n, 1);
                   n := pos (' ', s)
                 until n = 0;

 write (' Found ');                            {tell, that's happening}
 scount := scount + 1;                         {increment index to array s}
 write ('(', scount:3, '); ');
 write (s1, '.', s2);                          {print file name to console}
 sar [scount] := s;                            {load array}

  if usernum > 0                               {hidden file detected}
  then begin write(chr (7),
         '   < --- This file from user area ',
         usernum, '.-');
       end;

writeln;

   if scount = siz
   then begin lastent:= true;
              writeln ( chr(7), 'Buffer full error.-')
        end;

end;

procedure writit;                              {writing array s to file f}
var n: integer;
begin
  if scount > 0                                {... but only, if filled}
    then
    for n:= 1 to scount do
      begin {$I-}writeln (f, sar [n]);{$I+}
        if ioresult <> 0
        then begin writeln;
               writeln
               ( chr (7),
               '--- Write Error to PSEND.CMF.-');
               exit
             end;
      end;
end;

begin                                          {main of CMDMAK}
  writeln;
  writeln
  ('CMDMAK; writing contents of current disk to A:PSEND.CMF (Joe/17-10-83)');
  writeln
  ('----------------------------------------------------------------------');
  writeln;
  assign (f, 'A:PSEND.CMF'); {$I-}reset (f);{$I+}
    if ioresult = 0
    then begin repeat writeln;
                 write ('+++ File A:PSEND.CMF exists. Delete (Y/N)? ');
                 read (c);
                 clrbit (c, 5)
               until c in ['Y', 'N'];

       if c = 'N'
           then begin writeln;
                  writeln ('+++ Program CMDMAK aborted.-');
                  exit
                end;
         end;

  writeln;
  {$I-}rewrite (f);{$I+}

  if ioresult <> 0
  then begin writeln;
         writeln ('Could not open PSEND.CMF.', chr (7));
         exit
       end;

  writeln; firstent:= true; lastent:= false;

  repeat getput                                {filling array sar}
  until lastent;

 writit;                                       {writing array sar to file f}

 {$I-}close (f);{$I+}
 if ioresult<>0
 then begin writeln;
        writeln
        ('--- Could not close A: PSEND.CMF.-', chr (7))
      end;

 writeln; writeln ('+++ Program CMDMAK terminated.-')
end.