ftp.barnyard.co.uk/2015.02.ftp.barnyard.co.uk.tar/ftp.barnyard.co.uk/cpm/walnut-creek-CDROM/CPM/TURBOPAS/EXTFN.ARK/EXTFN.UNT

Text File | 1989-09-27 | 19KB | 528 lines

{.L-}  { Suppress listing by LISTT }
{*
 * --------------------------------------------------------------------
 *         E X T E N D E D   F I L E   N A M E S   U N I T
 * --------------------------------------------------------------------
 *
 * With this 'unit' the possibility to specify extended file names in
 * Turbo Pascal programs is created.  An extended file includes also
 * the user number of the file, thus an extended file name looks like:
 *    <Disk><User_Number>:<Primary_Name>.<Secondary_Name>
 * The extended file name can be an ambigious file name. However neither
 * the disk number nor the user number can be 'wildcards'.
 *
 * The implementation does not contain any hardware dependencies.
 *
 *               I N T E R F A C E   S E C T I O N
 *}
type
   FileTypes      = ( DiskFile,        { Disk file }
                      Device   ) ;     { Logical device }
   FileNameTypes  = ( DUNE_Format,     { Extended file name }
                       DNE_Format,     { Full CP/M file name }
                        NE_Format ) ;  { Only primary & secondary name }
   FullFileNames  = string[16] ;       { Extended file name }

   FileDescriptors= record
                      FileType: FileTypes ;  { File type }
                      Drive   :      Byte ;  { Drive number }
                      User    :      Byte ;  { User number }
                      Name    : string[8] ;  { Primary name }
                      Ext     : string[3] ;  { Secondary name }
                    end ;

{
 function  ExpandFileName( var FileDesc : FileDescriptors ;
                               NameType : FileNameTypes ) : FullFileNames ;

 procedure InitFileNameUnit ;

 procedure RegisterFile  ( var FileDesc : FileDescriptors ;
                           var SomeFile ) ;

 function  SameName      ( var FileDesc1: FileDescriptors ;
                           var FileDesc2: FileDescriptors ,
                               NameType : FileNameTypes ) : Boolean ;

 procedure SplitFileName ( var FileDesc : FileDescriptors ;
                               FileName : FullFileNames ) ;

 procedure UnInitFileNameUnit ;

 procedure UnRegisterFile( var SomeFile ) ;
}

{*
 *         I M P L E M E N T A T I O N   S E C T I O N
 *}
const
   MaxRXFCnt     =  3 ;  { Maximum number of registered FCBs - 1 }

type
   JumpStructures = record
                      Instruction :    Byte ;  { Jump instruction }
                      Address     : Integer ;  { Jump address }
                    end ;
   RegisteredFCBs = array[0..MaxRXFCnt] of record
                      FCBAddress  : Integer ;  { Address of FCB }
                      UserNumber  :    Byte ;  { Associated user }
                    end ;
var
   BDosEntry : JumpStructures ;  { Jump into original BDos }
   RXFCnt    :           Byte ;  { Number of Registered eXtended FCBs }
   RXFLst    : RegisteredFCBs ;  { List of registered extended FCBs }

procedure OwnBDos ;
{*
 * OwnBDos is a front-end to the standard BDos. Through a modification
 * of the jump vector, this procedure is called by the pascal runtime
 * routines.  OwnBDos implements the extended file names: before each
 * file operation, the user number associated with the file is selected
 * and upon completion the original user number is restored.
 *
 * The following BDos functions are handled by this procedure:
 *   15 - Open File
 *   16 - Close File
 *   19 - Delete File
 *   20 - Read Sequential
 *   21 - Write Sequential
 *   22 - Make File
 *   33 - Read Random
 *   34 - Write Random
 *   35 - Compute File Size
 *}
var
   CurUsr : Byte ;  { Save area of user number }
begin
   InLine(
     $3A /      RXFCnt / {LD   A,(RXFCNT) Number of registred FCB's }
     $B7 /               {OR   A          Set condition codes}
     $28 / $19 /         {JR   Z,EXT010   Exit if none registred }
     $79 /               {LD   A,C        Function code }
     $D6 / $0F /         {SUB  15         Compare with lower bound, 15 }
     $38 / $14 /         {JR   C,EXT010   Exit if non-disk function }
     $D6 / $02 /         {SUB  16+1-15    Compare with upper bound, 16 }
     $38 / $13 /         {JR   C,EXT020   Brif a disk function }
     $D6 / $02 /         {SUB  19-16-1    Compare with lower bound, 19 }
     $38 / $0C /         {JR   C,EXT010   Exit if non-disk function }
     $D6 / $04 /         {SUB  22+1-19    Compare with upper bound, 22 }
     $38 / $0B /         {JR   C,EXT020   Brif a disk function }
     $D6 / $0A /         {SUB  33-22-1    Compare with lower bound, 33 }
     $38 / $04 /         {JR   C,EXT010   Exit if non-disk function }
     $D6 / $03 /         {SUB  35+1-33    Compare with upper bound, 35 }
     $38 / $03 /         {JR   C,EXT020   Brif a disk function }
     $C3 /   BDosEntry / {JP   BDOS       Enter BDOS }
     $FD / $21 /RXFLst / {LD   IY,RXFLST  List of registered FCB's }
     $3A /      RXFCnt / {LD   A,(RXFCNT) Number of registered FCB's }
     $47 /               {LD   B,A        Move number }
     $FD / $6E / $00   / {LD   L,(IY+0)   LSB of registered FCB address }
     $FD / $66 / $01   / {LD   H,(IY+1)   MSB of registered FCB address }
     $B7 /               {OR   A          Clear carry flag }
     $ED / $52 /         {SBC  HL,DE      Compare with supplied FCB address }
     $28 / $0B /         {JR   Z,EXT030   Brif FCB found in list }
     $FD / $23 /         {INC  IY         Move pointer to next entry }
     $FD / $23 /         {INC  IY }
     $FD / $23 /         {INC  IY }
     $10 / $ED /         {DJNZ EXT025     Brif not at end of list }
     $C3 /   BDosEntry / {JP   BDOS       Exit if non-registered FCB }
     $C5 /               {PUSH BC         Save BDos function code }
     $D5 /               {PUSH DE         Save FCB address }
     $0E / $20 /         {LD   C,020H     Function= Get/Set_User_Number }
     $1E / $FF /         {LD   E,0FFH     Select Get_User_Number function }
     $CD /   BDosEntry / {CALL BDOS       Invoke BDos }
     $32 /      CurUsr / {LD   (CURUSR),A Save current user number }
     $0E / $20 /         {LD   C,020H     Function= Get/Set_User_Number }
     $FD / $5E / $02   / {LD   E,(IY+2)   Load requested user number }
     $CD /   BDosEntry / {CALL BDOS       Invoke BDos }
     $D1 /               {POP  DE         Restore address of FCB }
     $C1 /               {POP  BC         Restore BDos function code }
     $CD /   BDosEntry / {CALL BDOS       Invoke BDos }
     $F5 /               {PUSH AF         Save return code }
     $0E / $20 /         {LD   C,020H     Function=Get/Set_User_Number }
     $3A /      CurUsr / {LD   A,(CURUSR) Original user number }
     $5F /               {LD   E,A         }
     $CD /   BDosEntry / {CALL BDOS       Invoke BDos }
     $F1 ) ;             {POP  AF         Restore return code from disk }
end ;  { of OwnBDos }


function GetUserNumber : Integer ;
{*
 * GetUserNumber - Retrieve the user number. The returned number is in
 *                 the range [1,16]!
 *}
const
   GetSetUserNmbr= 32 ;  { BDos function: get or set the user number }
begin
   GetUserNumber:= Succ( BDos( GetSetUserNmbr, $00FF ) ) ;
end ;  { of GetUserNumber }

function GetDiskNumber : Integer ;
{*
 * GetDiskNumber - Retrieve the current disk number. The returned number
 *                 is in the range [1,16]!
 *}
const
   GetCurrentDisk= 25 ;  { BDos function: return ordinal of current disk }
begin
   GetDiskNumber:= Succ( BDos( GetCurrentDisk ) ) ;
end ;  { of GetDiskNumber }

function ExpandFileName( var FileDesc: FileDescriptors ;
                             NameType: FileNameTypes ) : FullFileNames ;
{*
 * ExpandFileName - Create the file name in a string from an (extended)
 * file descriptor.  A 'current' specification of both the drive and
 * the user are replaced by their actual values.
 *}
var
   Result : FullFileNames ;  { Result of function }
begin
   with FileDesc do
    begin
     if FileType=Device then
       Result:= Name
     else  { if FileType=Diskfile then }
      begin
       Result:= '' ;
       if NameType=DUNE_Format then
         if User=0 then
           Str( Pred(GetUserNumber), Result )
         else
           Str( Pred(         User), Result ) ;

       if NameType<>NE_Format then
         if Drive=0 then
           Result:= Chr(GetDiskNumber + Pred(Ord('A'))) + Result + ':'
         else
           Result:= Chr(Drive         + Pred(Ord('A'))) + Result + ':' ;

       Result:= Result + Name + '.' + Ext ;
      end ;  { of if }
    end ;  { of with }

   ExpandFileName:= Result ;
end ;  { of ExpandFileName }

procedure RegisterFile( var FileDesc: FileDescriptors ; var FIB ) ;
{*
 * RegisterFile - Register an extended file: the full name is given in
 *                the descriptor and the Pascal FileInterfaceBlock (FIB)
 *                specifies which FCB will be used.
 *
 * This procedure is needed to effectuate the user number specified in
 * the file descriptor.
 *}
var
   FIBFCB : Integer ;  { Address of FCB within FIB }
   I      : Integer ;  { Loop control variable }
begin
{*
 * Register only disk files: logical device names do not have a user number
 * associated with them.
 *}
   if FileDesc.FileType=DiskFile then
    begin
     FIBFCB:= Addr(FIB ) + 12 ;
{*
 * Locate either a free entry or an entry which specifies the same FCB.
 * The RegisterFile performs thus implicitly an 'UnRegisterFile'.
 *}
     I:= -1 ;
     repeat
       I:=Succ(I)
     until (I=RXFCnt) or (RXFLst[I].FCBAddress=FIBFCB) ;

     if I<=MaxRXFCnt then
      begin
       with RXFLst[I] do
        begin
         FCBAddress:= FIBFCB ;
         if FileDesc.User=0 then
           UserNumber:= Pred( GetUserNumber )
         else
           UserNumber:= Pred( FileDesc.User ) ;
        end ;  { of with }
       if I=RXFCnt then
         RXFCnt:= Succ( RXFCnt ) ;
      end
     else
       Halt ;  { Fatal error : Table Overflow }
   end ;  { of if }
end ;  { of RegisterFile }

function SameName( var FileDesc1, FileDesc2 : FileDescriptors ;
                       NameType             : FileNameTypes ) : Boolean ;
{*
 * SameName - Determine whether two ambigious (!) file descriptors specify
 *            the same file name.
 *
 * The comparison algorithm classifies the characters from the file
 * names into five classes: '?', '.'. ':', 'other character' and
 * 'end of name'.  Using this classification, the algorithm is
 * specified by the following state table:
 *
 *        |  ?  |  .  |  :  | Oth | End    Description of actions
 *   -----+-----+-----+-----+-----+-----   -------------------------
 *     ?  |  0  |  1  |  1  |  0  |  1     0 : Advance both pointers
 *   -----+-----+-----+-----+-----+-----   1 : Advance pointer # 1
 *     .  |  2  |  0  |  3  |  3  |  1     2 : Advance pointer # 2
 *   -----+-----+-----+-----+-----+-----   3 : Mismatch & Exit
 *     :  |  2  |  3  |  0  |  3  |  1     4 : Compare
 *   -----+-----+-----+-----+-----+-----       if mismatch then (3)
 *    Oth |  0  |  3  |  3  |  4  |  3         if match    then (0)
 *   -----+-----+-----+-----+-----+-----   5 : Match & Exit
 *    End |  2  |  2  |  2  |  3  |  5
 *   -----+-----+-----+-----+-----+-----
 *}
const
   SintJuttemis = False ;

type
   Classes = ( Wildcard, Dot, Colon, Other, EndOfName ) ;
   Actions = ( Act0, Act1, Act2, Act3, Act4, Act5 ) ;

const
   StateTable : array[Classes] of array[Classes] of Actions =
                ( ( Act0, Act1, Act1, Act0, Act1 ),
                  ( Act2, Act0, Act3, Act3, Act1 ),
                  ( Act2, Act3, Act0, Act3, Act1 ),
                  ( Act0, Act3, Act3, Act4, Act3 ),
                  ( Act2, Act2, Act2, Act3, Act5 ) ) ;

var
   File1 : FullFileNames ;  { Expanded name of first file }
   File2 : FullFileNames ;  { Expanded name of second file }
   Index1:       Integer ;  { Index in File1 name string }
   Index2:       Integer ;  { Index in File2 name string }
   Action:       Actions ;  { Action for current character pair }

 function ClaNC( var FileName : FullFileNames ;
                 var Index    :       Integer ) : Classes ;
 {*
  * ClaNC - CLAssify_Next_Character : Extract the next character from the
  *         name of the file and classify it.
  *}
 begin
    if Index>Length(FileName) then
      ClaNC:= EndOfName
    else
     begin
      case FileName[Index] of
        '.' : ClaNC:= dot ;
        ':' : ClaNC:= colon ;
        '?' : ClaNC:= WildCard ;
      else
        ClaNC:= Other ;
      end ;  { of case }
     end ;  { of if }
 end ;  { of ClaNC }

begin
   File1:= ExpandFileName( FileDesc1, NameType ) ;
   File2:= ExpandFileName( FileDesc2, NameType ) ;

   Index1:= 1 ;
   Index2:= 1 ;
   repeat
     Action:= StateTable[ ClaNC(File1,Index1), ClaNC(File2,Index2) ] ;
     case Action of
       Act0 : begin
               Index1:= Succ( Index1 ) ;
               Index2:= Succ( Index2 ) ;
              end ;  { of case Act0 }
       Act1 : begin
               Index1:= Succ( Index1 ) ;
              end ;  { of case Act1 }
       Act2 : begin
               Index2:= Succ( Index2 ) ;
              end ;  { of case Act2 }
       Act3 : begin
               SameName:= False ;  { Set function result }
               Exit ;              { Return to caller }
              end ;  { of case Act3 }
       Act4 : begin
               if File1[Index1]=File2[Index2] then
                begin
                 Index1:= Succ( Index1 ) ;
                 Index2:= Succ( Index2 ) ;
                end
               else
                begin
                 SameName:= False ;
                 Exit ;
                end ;  { of if }
              end ;  { of case Act4 }
       Act5 : begin
               SameName:= True ;  { Set function result }
               Exit ;             { Return to caller }
              end ;  { of case Act5 }
     end ;  { of case }
   until SintJuttemis ;
end ;  { of SameName }

procedure SplitFileName( var FileDesc: FileDescriptors ;
                             FileName: FullFileNames ) ;
{*
 * SplitFileName - Split up the extended name of a file into its components.
 *                 The wildcard character '*' is expanded to multiple '?',
 *                 until the end of the field.
 *}
type
   SomeStrings = string[16] ;  { Some string which is big enough }
var
   DevName    : string[5] ;  { (Possible) device name }
   I          :   Integer ;  { Pointer to field separator }
   Result     :   Integer ;  { Result of string-to-integer conversion }
   ReturnCode :   Integer ;  { Return code from 'Val' procedure }

 function Trim( SomeString : SomeStrings ) : SomeStrings ;
 {*
  * Trim - Remove the leading and the trailing spaces from a string and
  *        expand the '*' wild character.
  *}
 var
    I : Integer ;  { Position of '*' in string }
 begin
 {*
  * Remove the leading blank spaces .
  *}
    while (Length(SomeString)>0) and (SomeString[1]=' ') do
      Delete( SomeString, 1, 1 ) ;
 {*
  * Remove the trailing blank spaces.
  *}
    while (Length(SomeString)>0) and (SomeString[Length(SomeString)]=' ') do
      Delete( SomeString, Length(SomeString), 1 ) ;
 {*
  * Change all lowercase characters into uppercase characters.
  *}
    if Length(SomeString)>0 then
      for I:= 1 to Length(SomeString) do
        SomeString[I]:= UpCase(SomeString[I]) ;
 {*
  * Expand the first '*' wildcharacter into multiple '?' wild characters,
  * filling up the field.  Truncation at the assignment of the function value
  * is assumed in this code, as the maximum length of SomeString isn't known.
  *}
    I:= Pos( '*', SomeString ) ;
    if I>0 then
      SomeString:= Copy( SomeString, 1, Pred(I) ) + '????????' ;

    Trim:= SomeString ;
 end ;  { of Trim }

begin
   FileDesc.FileType := DiskFile ;
   FileDesc.Drive    :=  0 ;
   FileDesc.User     :=  0 ;
   FileDesc.Name     := '' ;
   FileDesc.Ext      := '' ;

{*
 * Check for a name of a logical device.
 *}
   DevName:= Trim( FileName ) ;
   if Length(DevName)=4 then
     if DevName[4]=':' then
       if Pos( DevName, 'CON:TRM:KBD:LST:AUX:USR:' )<>0 then
        begin
         FileDesc.FileType:= Device ;
         FileDesc.Name    := Trim(FileName) ;
         Exit ;
        end ;  { of if/if/if }

{*
 * Extract the secondary name from the file name.
 *}
   I:= Pos( '.', FileName ) ;
   if I>0 then
    begin
     FileDesc.Ext:= Trim( Copy(FileName, Succ(I), 3) ) ;
     FileName:= Copy( FileName, 1, Pred(I) ) ;
    end ;  { of if }
{*
 * Extract the primary name from the file name.
 *}
   I:= Pos( ':', FileName ) ;
   FileDesc.Name:= Trim( Copy(FileName, Succ(I), 8) ) ;
{*
 * Extract the drive name and the user number from the file name.
 *}
   if I>1 then
    begin
     FileName:= Copy( FileName, 1, Pred(I) ) ;
{*
 * Look for the drive name.
 *}
     if FileName[1] in ['A'..'P','a'..'p'] then
      begin
       FileDesc.Drive:= Succ( Ord(UpCase(FileName[1])) - Ord('A') ) ;
       FileName:= Copy( FileName, 2, I ) ;
      end ;  { of if }
{*
 * Look for the user number.
 *}
     if Length(FileName)>0 then
      begin
       Val( FileName, Result, ReturnCode ) ;
       if ReturnCode=0 then
         FileDesc.User:= Succ(Result) ;
      end ;  { of if }
    end ;  { of if }
end ;  { of SplitFileName }

procedure UnRegisterFile( var FIB ) ;
{*
 * UnRegisterFile - Remove the registration of file with the given FIB
 *                  from the list.
 *}
var
   FIBFCB : Integer ;  { Address of FCB within FIB }
   I      : Integer ;  { Loop control variable }
begin
   FIBFCB:= Addr(FIB ) + 12 ;
{*
 * Locate the entry which specifies the same FCB.
 *}
   I:= -1 ;
   repeat
     I:=Succ(I)
   until (I=RXFCnt) or (RXFLst[I].FCBAddress=FIBFCB) ;

   if I<RXFCnt then  { remove the located entry }
    begin
     RXFCnt:= Pred(RXFCnt) ;
     while I<RXFCnt do  { shift the succeeding entries }
      begin
       RXFLst[I]:= RXFLst[Succ(I)] ;
       I        :=        Succ(I)  ;
      end ;  { of while }
    end ;  { of if }
end ;  { of UnRegisterFile }

procedure InitFileNameUnit ;
{*
 * Install the BDos extension (filter).
 *}
var
   BDosAddress : Integer absolute $0006 ;  { Address of BDos entry point }
begin
   BDosEntry.Instruction:=         $C3 ;  { Jump instruction }
   BDosEntry.Address    := BDosAddress ;  { Save address of BDos entry point }
   BDosAddress:= Addr( OwnBDos ) ;        { Install own BDos extension }

   RXFCnt:= 0 ;
end ;  { of InitFileNameUnit }

procedure UnInitFileNameUnit ;
{*
 * Restore the original BDos entry, thus removing the BDos extension.
 *}
var
   BDosAddress : Integer absolute $0006 ;  { Address of BDos entry point }
begin
   BDosAddress:= BDosEntry.Address ;  { Restore original BDos entry point }
end ;  { of UnInitFileNameUnit }
{.L+}