CP/M/CPM_CDROM.iso/cpm/utils/dskutl/swp-ms10.ark/TRAMDF.IF6

Text File | 1989-09-27 | 19.5 KB | 604 lines

{* ------------------------------------------------------------------------- *}
{*                    S E C O N D   L E V E L   M E N U S
{* ------------------------------------------------------------------------- *}

procedure ExecuteEpilogue ;  forward ;

procedure SetDefaults ;
{*
 * Set the default values for the CP/M and MS-DOS drive names.  Upon
 * exit, the MS-DOS drive is assigned and installed!
 *}
var
   NewDate: DateStrings ;  { Today's date }
   Code   :        Char ;  { Command character }
const
   OSName     : array[Oss]         of string[ 6] =
                ( 'CP/M', 'MS-DOS' ) ;
   NameOfClass: array[FileClasses] of string[12] =
                ( 'Text file', 'Binary file', 'Ask per file' ) ;
   YesNo      : array[Boolean]     of string[ 3] =
                ( ' No', 'Yes' ) ;

 procedure ReadByte( var SomeByte: Byte ) ;
 {*
  * Read the (new) value for one of the padding characters.
  *}
 var
    NextChar: Char ;  { Next character read }

  procedure ReadNextCharacter ;
  {*
   * Read and process one nibble (a four-bit quantity).
   *}
  var
     Found: Boolean ;  { Legal character entered }
  begin
     repeat
       Read( Kbd, NextChar ) ;
       NextChar:= UpCase( NextChar ) ;
       Found:= (NextChar in ['0'..'9','A'..'F',^M]) ;
       if not Found then
         Write( ^G ) ;
     until Found ;
     Write( NextChar ) ;
     if NextChar<>^M then
      begin
       SomeByte:= (SomeByte shl 4) + Ord(NextChar) ;
       if NextChar<'A' then
         SomeByte:= SomeByte - Ord('0')
       else
         SomeByte:= SomeByte - Ord('A') + 10 ;
      end ;  { of if }
  end ;  { of ReadNextCharacter }

 begin
    Write( ^M^J'Enter hex character code : $' ) ;
    SomeByte:= 0 ;
    ReadNextCharacter ;
    if NextChar<>^M then
      ReadNextCharacter ;
 end ;  { of ReadByte }

 procedure SetCpmOptions ;
 var
    Code: Char ;  { Command code }
 begin
    repeat
      DisplayTitle( 'MS-DOS -> CP/M copy options' ) ;
      DisplayMenuHead ;
      WriteLn( ' <C>  Copy file attributes = ', YesNo[CopyCpmFileAttr] ) ;
      WriteLn( ' <F>  File type            = ', NameOfClass[FileClass] ) ;
      WriteLn( ' <T>  Text file pad char.  = $', Hex(CpmTxtFillChar,2) ) ;
      WriteLn( ' <B>  Binary file pad char.= $', Hex(CpmBinFillChar,2) ) ;
      DisplayMenuTail ;
      ReadCommand( Code ) ;
      case Code of
        'B' : ReadByte( CpmBinFillChar ) ;
        'C' : CopyCpmFileAttr:= not CopyCpmFileAttr ;
        'F' : if FileClass=AskUser then
                FileClass:= TextFile
              else
                FileClass:= Succ( FileClass ) ;
        'Q' : ;
        'T' : ReadByte( CpmTxtFillChar ) ;
      else
        IllegalCommand ;
      end ;  { of cases }
    until Code='Q' ;
 end ;  { of SetCpmOptions }

 procedure SetMsdosOptions ;
 var
    Code: Char ;  { Command code }
 begin
    repeat
      DisplayTitle( 'CP/M -> MS-DOS copy options' ) ;
      DisplayMenuHead ;
      WriteLn( ' <C>  Copy file attributes  = ', YesNo[CopyMsdosFileAttr] ) ;
      WriteLn( ' <P>  Cluster pad character = $',    Hex(MsdosFillChar,2) ) ;
      WriteLn( ' <F>  File type             = ',   NameOfClass[FileClass] ) ;
      DisplayMenuTail ;
      ReadCommand( Code ) ;
      case Code of
        'C' : CopyMsdosFileAttr:= not CopyMsdosFileAttr ;
        'F' : if FileClass=AskUser then
                FileClass:= TextFile
              else
                FileClass:= Succ( FileClass ) ;
        'P' : ReadByte( MsdosFillChar ) ;
        'Q' : ;
      else
        IllegalCommand ;
      end ;  { of cases }
    until Code='Q' ;
 end ;  { of SetMsdosOptions }

begin
   repeat
     DisplayTitle( 'Set default values' ) ;
     DisplayMenuHead ;
     WriteLn( ' <C>  CP/M default drive/user     = ',
               ExpandFileName(CpmDriveName,DU_Format):4 ) ;
     WriteLn( ' <M>  MS-DOS drive                = ',
               MsdosDriveName:3, ':' ) ;
     WriteLn( ' <S>  Source drive                = ',
               OSName[SourceOs] ) ;
     WriteLn ;
     WriteLn( ' <T>  Today''s date                = ', TodaysDate ) ;
     WriteLn( ' <D>  Display disk parameters     >' ) ;
     WriteLn( ' <A>  CP/M -> MS-DOS copy options >' ) ;
     WriteLn( ' <B>  MS-DOS -> CP/M copy options >' ) ;
     WriteLn ;
     Write  ( ' <E>  Exit from program' ) ;
     DisplayMenuTail ;
     ReadCommand( Code ) ;
     case Code of
       'A' : SetMsdosOptions ;
       'B' : SetCpmOptions ;
       'C' : begin
               WriteLn ;
               SetCpmDrive ;
             end ;  { of case C }
       'D' : DisplayMsdosDiskParameters ;
       'E' : begin
               ExecuteEpilogue ;     { Clean up BIOS tables }
               UnInitFileNameUnit ;  { Remove BDOS shell }
               Halt ;
             end ;  { of case E }
       'M' : begin
               WriteLn ;
               SetMsdosDrive ;
             end ;  { of case M }
       'Q' : if MsdosDriveName='?' then
              begin
               FlagError( 'SetD: MS-DOS drive unspecified' ) ;
               Code:=  '?' ;  { Inhibit termination of the loop }
              end ;  { of case Q }
       'S' : if SourceOS=Cpm then
              begin
               SourceOS     := Msdos ;
               DestinationOS:=   Cpm ;
              end
             else  { if SourceOS=Msdos then }
              begin
               SourceOS     :=   Cpm ;
               DestinationOS:= Msdos ;
              end ;  { of if/case 'X' }
       'T' : begin
               WriteLn ;
               Write( 'Enter date [yyyymmdd] : ' ) ;
               ReadLn( NewDate ) ;
               SetTodaysDate( NewDate ) ;
             end ;  { of case 'T' }
     else
       IllegalCommand ;
     end ;  { of case }
     ReportError ;
   until Code='Q' ;
end ;  { of SetDefaults }

procedure EnterFileManager ;
{*
 * Enter a line-oriented filemanager a la SWEEP.  For a proper operation of
 * this procedure, the MS-DOS drive should be assigned (set). In other words,
 * the MsdosDriveName should not be '?'.
 *}
type
   PathNames   = string[40] ;  { Description of path to source/destination }
   CommandCodes=   ' '..'~' ;  { Set of possible command codes }
var
   AllowedCommands:     set of CommandCodes ;  { Currently allowed commands }
   PathName       : array[OSs] of PathNames ;  { Cpm & Msdos paths }

   NewHeader: Boolean ;  { Display screen header (again) }
   NewLine  : Boolean ;  { Display file entry on a new line }
   Code     :    Char ;  { Command code }
   I        : Integer ;  { Loop control variable }

 procedure AskFileClass ;
 begin
    if ReadYesNoAnswer( 'Text file' )='Y' then
      FileClass:= TextFile
    else
      FileClass:= BinaryFile ;
 end ;  { of AskFileClass }

 procedure DeleteFile( OS: OSs ) ;
 begin
    if OS=Cpm then  DeleteCpmFile
              else  DeleteMsdosFile ;
 end ;  { of DeleteFile }

 function GetFreeSpace( OS: OSs ) : Integer ;
 begin
    if OS=CPm then GetFreeSpace:= GetCpmFreeSpace
              else GetFreeSpace:= GetMsdosFreeSpace ;
 end ;  { of GetFreeSpace }

 function LocateFile( OS: OSs ) : Boolean ;
 begin
    if OS=Cpm then  LocateFile:= LocateCpmFile
              else  LocateFile:= LocateMsdosFile ;
 end ;  { of LocateFile }

 procedure ChangeMsdosPath ;
 {*
  * Change the MS-DOS path to the directory associated with the current
  * file entry.
  *}
 type
    NameString= string[11] ;  { String to contain file name }
 var
    SubDirName: NameString ;  { Name of (sub)directory }

  function Trim( SomeString: NameString ) : NameString ;
  {*
   * Remove the trailing spaces from a name.
   *}
  begin
     while (Length(SomeString)>0) and (SomeString[Length(SomeString)]=' ') do
       Delete( SomeString, Length(SomeString), 1 ) ;
     Trim:= SomeString ;
  end ;  { of Trim }

 begin
    if LocateMsdosDirectory then
     begin
 {*
  * Save the number of the first cluster containing the FCB's of this
  * (sub)directory.  A zero value indicates the root directory.  Note that
  * the other Directory... variables are set at the initialisation of a
  * new search through the (sub)directory.
  *}
      DirectoryStartCls:= MsdosFcb^.Cluster ;
  {*
   * Update the name of the path to the current directory.
   *}
      SubDirName:= Trim( MsdosFcb^.FileName ) ;
      if SubDirName='.' then
        { do nothing }
      else
        if SubDirName='..' then
          DirectoryNesting:= Pred( DirectoryNesting )
        else
         begin
          DirectoryNesting:= Succ( DirectoryNesting ) ;
          if DirectoryNesting<=MsdosPathSize then
            MsdosPath[DirectoryNesting]:= SubDirName + '\' ;
         end  { of else/else }
     end
    else
      FlagError( 'ChaMP: Can''t find directory ' + FileEntry^.Name ) ;
 end ;  { of ChangeMsdosPath }

 procedure CopyFile ;
 {*
  * Copy one file from the source disk to the destination disk.
  *}
 var
    OrigFileClass: FileClasses ; { Original file class }
 begin
    if not IsFile then
     begin
      Write( 'Can''t copy it.' ) ;
      Exit ;
     end ;  { of if }
 {*
  * Check if a file of that name already exeists on the destination disk.  If
  * so, ask the user if that file can be destroyed.  If not, exit immediatly.
  *}
    if LocateFile( DestinationOS ) then
      if not ErrorDetected then
        if ReadYesNoAnswer( 'Overwrite file' )='Y' then
          DeleteFile( DestinationOS )
        else
          Exit ;
 {*
  * See if there is enough room on the destination disk to copy the file.
  *}
    if not ErrorDetected then
      if FileEntry^.Size>GetFreeSpace(DestinationOS) then
        FlagError( ^H': Not enough space on destination disk' ) ;
 {*
  * Determine the type if file.  This information is needed either to
  * determine the real end-of-file position (copy to MS-DOS) or to determine
  * padding of the last record (copy to CP/M).
  *}
    if not ErrorDetected then
     begin
      OrigFileClass:= FileClass ;
      if FileClass=AskUser then  AskFileClass ;

      if SourceOS=Cpm then  WriteMsdosFile   { Finally, go copy the file }
                      else  ReadMsdosFile ;

      FileClass:= OrigFileClass ;
     end ;  { of if }

    if not ErrorDetected then
      Write( 'Done.' )
    else
      BuildErrorTrace( 'CopF_' ) ;
 end ;  { of CopyFile }

 procedure CopyTaggedFiles ;
 {*
  * Copy all the tagged files to the destination disk.
  *}
 begin
    FileEntry:= HeadFileList ;
    while FileEntry<>TailFileList do
     begin
      if FileEntry^.Mark then
       begin
        WriteLn ;
        Write  ( 'Copying  --> ', GetFileEntryName, ' : ' ) ;
        CopyFile ;
        if ErrorDetected then
         begin
          ReportError ;
          FileEntry:= TailFileList^.Prev ;  { Terminate while loop }
         end
        else  { if there is no error detected }
         begin
          FileEntry^.Mark:= False ;
          SizeTaggedFiles:= SizeTaggedFiles - FileEntry^.Size ;
         end ;  { of else }
       end ;  { of if }
      FileEntry:= FileEntry^.Next ;
     end ;  { of while }

    FileEntry:= HeadFileList ;
    FileIndex:=            1 ;
 end ;  { of CopyTaggedFiles }

 procedure DisplayFreeSpace ;
 {*
  * Display the free disk space on both the CP/M and the MS-DOS disk.
  *}
 begin
    WriteLn ;
    WriteLn( 'Free disk space on CP/M   drive ', ExtractDisk(CpmDriveName),
             ': is ', GetCpmFreeSpace:4, ' KByte.' ) ;
    WriteLn( 'Free disk space on MS-DOS drive ', MsdosDriveName,
             ': is ', GetMsdosFreeSpace:4, ' KByte.' ) ;
 end ;  { of displayFreeSpace }

 procedure DisplayHelp ;
 {*
  * Display a short summary of all the supported filemanager commands.
  *}
 begin
    WriteLn ;  WriteLn ;
    WriteLn( ' < >  Advance one file     | <P>  Change MS-DOS path' ) ;
    WriteLn( ' <B>  Back one file        | <Q>  Quit' ) ;
    WriteLn( ' <C>  Copy file            | <S>  Select MS-DOS drive' ) ;
    WriteLn( ' <D>  Delete file          | <T>  Tag file' ) ;
    WriteLn( ' <E>  Erase tagged files   | <U>  Untag file' ) ;
    WriteLn( ' <F>  Show free disk space | <W>  Wildcard tag' ) ;
    WriteLn( ' <L>  Login CP/M drive     | <X>  Swap CP/M <-> MS-DOS' ) ;
    WriteLn( ' <M>  Copy tagged files    | <Z>  Set defaults' ) ;
    WriteLn ;
 end ;  { of DisplayHelp }

 procedure EraseFile ;
 {*
  * Erase (delete) the file associated with current filelist entry and
  * change the filelist to reflect this modification.
  *}
 begin  { of EraseFile }
 {*
  * Only a file can be deleted.  Exit if the entry is not a file.
  *}
    if not IsFile then
     begin
      Write( 'Can''t delete it.' ) ;
      Exit ;
     end ;  { of if }

    if ReadYesNoAnswer( 'Delete' )='Y' then
     begin
      DeleteFile( SourceOS ) ;
      DeleteFileEntry ;         { Adjusts SizeTaggedFiles too! }
     end
    else  { do not delete this file after all }
 {*
  * Advance to the next file in the list.  Thus, upon exit of this procedure,
  * the 'current' file entry is ALWAYS advanced, whether or not the file has
  * been deleted.  The procedure EraseTaggedFiles needs this behaviour!  Note
  * that only FILES can be tagged, thus if the 'IsFile' test at the beginning
  * of this procedure is negative, there is no need to advance to the next
  * file entry.
  *}
      AdvanceFileEntry ;
 end ;  { of EraseFile }

 procedure EraseTaggedFiles ;
 {*
  * Erase (delete) all the tagged files.  For each file the user must
  * acknowledge that the file must be deleted.
  *}
 begin
    FileEntry:= HeadFileList ;
    while FileEntry<>TailFileList do
     begin
      if FileEntry^.Mark then
       begin
        WriteLn ;
        Write  ( 'Deleting --> ', GetFileEntryName, ' : ' ) ;
        EraseFile ;
       end
      else { the file entry is not marked }
        FileEntry:= FileEntry^.Next ;
     end ;  { of while }
    FileEntry:= HeadFileList ;
    FileIndex:=            1 ;
 end ;  { of EraseTaggedFiles }

begin  { of EnterFileManager }
{*
 * Preset the control variables and build a file list from the directory on
 * the source drive.  If an error is detected while reading the directory,
 * exit from the file manager.
 *}
   if SourceOS=Cpm then  ReadCpmDirectory
                   else  ReadMsdosDirectory ;
   if ErrorDetected then
    begin
     ReportError ;
     Exit ;
    end ;  { of if }

(*   SetWindow( 5, 24 ) ;  { Define window for file manager } *)
(*   EnableWindow ; *)
   NewHeader:= True ;
   NewLine  := True ;
   repeat
     CpmCurrentDrive:= Bdos( GetCurrentDrive ) ;
{*
 * Display the header every time the CP/M drive/user selection or the MS-DOS
 * drive selection has changed.  The header identifies the source and the
 * destination of any copy command.  Note that in one of the WriteLn's the
 * assumption is hidden that the line width is 80 characters.
 *}
     if NewHeader then
      begin
       DisplayTitle( 'File Manager' ) ;
       PathName[Cpm  ]:= 'CP/M, ' +
                         ExpandFileName( CpmDriveName, DU_Format) ;
       PathName[Msdos]:= 'MS-DOS, ' + MsdosDriveName + ':' ;
       I:= 0 ;
       repeat
         PathName[Msdos]:= PathName[Msdos] + MsdosPath[I] ;
         I:= Succ( I ) ;
       until (I>DirectoryNesting) or (I>MsdosPathSize) ;

       WriteLn( 'Source = ', PathName[SourceOS],
                ' ':55-Length(PathName[Cpm])-Length(PathName[Msdos]),
                ' Destination = ', PathName[DestinationOS] ) ;
       NewHeader:= False ;
      end ;  { of if }
{*
 * Determine the set of allowed commands.  If the filelist is empty, the file
 * operations are not allowed (as they are not sensible).
 *}
     AllowedCommands:=[' ','.','?','B','C','D','E','F', { All command codes }
                       'L','M','P','Q','S','T','U','W','X','Z'] ;
     if SizeFileList=0 then
      begin
       AllowedCommands:= ['?','F','L','Q','S','X','Z'] ;
       if NewLine then
         Write( ^M^J'No files. ' ) ;
       NewLine:= False ;
      end ;  { of if }
{*
 * Display the current file entry.  Only in case of an erroneous command,
 * the file entry is not re-displayed.
 *}
     if NewLine then
       DisplayFileEntry ;
     NewLine:= True ;
{*
 * Read the next command for the file manager from the keyboard device.  All
 * non-printable characters are mapped onto the dot to make it visible.
 *}
     Read ( Kbd, Code ) ;
     if not (Code in [' '..'~']) then
       Code:= '.' ;
     Write( Code, ' ' ) ;
     Code:= UpCase( Code ) ;
     if Code in AllowedCommands then
{*
 * Process the next file manager command.
 *}
       case Code of
         ' ',
         '.' : AdvanceFileEntry ;
         '?' : DisplayHelp ;
         'B' : BackupFileEntry ;
         'C' : CopyFile ;
         'D' : EraseFile ;
         'E' : EraseTaggedFiles ;
         'F' : DisplayFreeSpace ;
         'L' : begin
                 SetCpmDrive ;
                 if SourceOS=Cpm then
                   ReadCpmDirectory ;
                 NewHeader:= True ;
               end ;  { of case 'L' }
         'M' : CopyTaggedFiles ;
         'P' : begin
                 if IsDirectory { and SourceOS=Msdos } then
                  begin
                   ChangeMsdosPath ;
                   ReadMsdosDirectory ;
                   NewHeader:= True ;
                  end   { of if }
                 else
                  begin
                   Write( ^G^H^H' '^H ) ;
                   NewLine:= False ;
                  end ;  { of else }
               end ;  { of case 'P' }
         'Q' : ;
         'S' : begin
                 SetMsdosDrive ;
                 if (SourceOS=Msdos) and (MsdosDriveName<>'?') then
                   ReadMsdosDirectory ;
                 NewHeader:= True ;
               end ;  { of case 'S' }
         'T' : begin
                 TagFileEntry ;
                 AdvanceFileEntry ;
               end ;  { of case 'T' }
         'U' : begin
                 UntagFileEntry ;
                 AdvanceFileEntry ;
               end ;  { of case 'U' }
         'W' : TagMultipleFileEntries ;
         'X' : if SourceOS=Cpm then
                begin
                 NewHeader    :=  True ;
                 SourceOS     := Msdos ;
                 DestinationOS:=   Cpm ;
                 ReadMsdosDirectory ;
                end
               else  { if SourceOS=Msdos then }
                begin
                 NewHeader    :=  True ;
                 SourceOS     :=   Cpm ;
                 DestinationOS:= Msdos ;
                 ReadCpmDirectory ;
                end ;  { of if/case 'X' }
         'Z' : begin
                 SetDefaults ;
                 Newheader:= True ;
               end ;  { of case 'Z' }
       end  { of cases }
{*
 * The command code is not supported or perhaps not allowed just now.  Give
 * an audible error indication and wipe-out the command code on the screen.
 *}
     else
      begin
       Write( ^G^H^H' '^H ) ;  { Remove illegal command code }
       NewLine:= False ;       { Do not write a next line }
      end ;  { of else }
     ReportError ;
{*
 * If the command to select another MS-DOS drive failed, indicated by a '?'
 * for the name, the user MUST select another drive, until it succeeds.
 *}
     if MsdosDriveName='?' then
      begin
       SetDefaults ;  { Force selection of another MS-DOS drive }
       NewHeader:= True ;
      end ;  { of if }
   until Code='Q' ;

(*   DisableWindow ; *)
end ;  { of EnterFileManager }