Simtel MSDOS 1992 June/SIMTEL_0692.cdr/msdos/dirutl/ddel124.arc/ALTFIO.MOD

Modula Implementation | 1989-07-15 | 5.5 KB | 171 lines

IMPLEMENTATION MODULE AltFIO;

  IMPORT SYSTEM, FIO, IO, Lib, Str;
  FROM SYSTEM IMPORT CarryFlag;

  PROCEDURE WrErr(name, msg: ARRAY OF CHAR);
    CONST bel = CHR(7);
  BEGIN
    IO.WrChar(bel);
    IO.WrStr(name);
    IO.WrStr(": ");
    IO.WrStr(msg);
    IO.WrLn
  END WrErr;

  PROCEDURE Fatal(pathname: ARRAY OF CHAR; errCode: CARDINAL); (* private *)
  BEGIN
    CASE errCode OF
      1: WrErr(pathname, "Invalid function number")
    | 2: WrErr(pathname, "File not found")
    | 3: WrErr(pathname, "Path not found")
    | 5: WrErr(pathname, "Access denied")
    |15: WrErr(pathname, "Invalid drive specification")
    |16: WrErr(pathname, "Attempt to remove the current directory")
    END;
    HALT
  END Fatal;

  PROCEDURE SetAttr(pathname: ARRAY OF CHAR; attr: FIO.FileAttr);
   VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 43H;                (* Get or Set File Attributes (CHMOD) *)
      AL := 01H;                (* Set attributes *)
      CH := 0H;                 (* Clear upper byte of CX *)
      CL := SHORTCARD(attr);    (* Desired attributes *)
      DS := SYSTEM.Seg(pathname);
      DX := SYSTEM.Ofs(pathname);
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF CarryFlag IN Flags THEN Fatal(pathname, AX) END
    END
  END SetAttr;

  PROCEDURE ReadFirstEntry(pathname: ARRAY OF CHAR;
                           attr: FIO.FileAttr;
                           VAR D: FIO.DirEntry): BOOLEAN;
    VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 1AH;                (* Set DTA *)
      DS := SYSTEM.Seg(D);
      DX := SYSTEM.Ofs(D);
      Lib.Dos(r);               (* INT 21H Function Call *)
      AH := 4EH;                (* FIND FIRST *)
      CL := SHORTCARD(attr);    (* File attribute *)
      DS := SYSTEM.Seg(pathname);(* Pointer to filespec *)
      DX := SYSTEM.Ofs(pathname);
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF CarryFlag IN Flags THEN
        IF AX = 18 THEN RETURN FALSE
        ELSE Fatal(pathname, AX)
        END
      ELSE RETURN TRUE
      END
    END
  END ReadFirstEntry;

  PROCEDURE ReadNextEntry(VAR D: FIO.DirEntry): BOOLEAN;
    VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 1AH;                (* Set DTA *)
      DS := SYSTEM.Seg(D);
      DX := SYSTEM.Ofs(D);
      Lib.Dos(r);               (* INT 21H Function Call *)
      AH := 4FH;                (* FIND NEXT *)
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF (CarryFlag IN Flags) OR (AX = 18) THEN
        RETURN FALSE
      ELSE RETURN TRUE
      END
    END
  END ReadNextEntry;

  PROCEDURE ChDir(pathname: ARRAY OF CHAR);
    VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 3BH;                (* CHDIR *)
      DS := SYSTEM.Seg(pathname);(* Pointer to new default directory name *)
      DX := SYSTEM.Ofs(pathname);
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF CarryFlag IN Flags THEN Fatal(pathname, AX) END
    END
  END ChDir;

  PROCEDURE RmDir(pathname: ARRAY OF CHAR);
    VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 3AH;                (* RMDIR *)
      DS := SYSTEM.Seg(pathname);(* Pointer to directory name to remove *)
      DX := SYSTEM.Ofs(pathname);
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF CarryFlag IN Flags THEN Fatal(pathname, AX) END
    END
  END RmDir;

  PROCEDURE Erase(pathname: ARRAY OF CHAR);
    VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 41H;                (* Delete File (UNLINK) *)
      DS := SYSTEM.Seg(pathname);(* Pointer to directory name to remove *)
      DX := SYSTEM.Ofs(pathname);
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF CarryFlag IN Flags THEN Fatal(pathname, AX) END
    END
  END Erase;

  PROCEDURE AddDrive(drive: SHORTCARD; VAR pathname: ARRAY OF CHAR);
  BEGIN
    Str.Insert(pathname, " :", 0);
    pathname[0] := CHR( CARDINAL(drive) + ORD('A') )
  END AddDrive;

  PROCEDURE GetDir(drive: SHORTCARD;            (* private procedure *)
                   VAR pathname: ARRAY OF CHAR);
    VAR r: SYSTEM.Registers;
  BEGIN
    WITH r DO
      AH := 47H;                (* Get Current Directory *)
      DL := drive;              (* Drive number (0=default, 1=A, etc.) *)
      DS := SYSTEM.Seg(pathname);(* Pointer to 64-byte buffer *)
      SI := SYSTEM.Ofs(pathname);
      Lib.Dos(r);               (* INT 21H Function Call *)
      IF CarryFlag IN Flags THEN Fatal(pathname, AX) END
    END
  END GetDir;

  PROCEDURE GetDrive(): SHORTCARD;      (* private procedure *)
    VAR r: SYSTEM.Registers;
  BEGIN
    r.AH := 19H;                (* Get Current Disk *)
    Lib.Dos(r);                 (* INT 21H Function Call *)
    RETURN r.AL
  END GetDrive;

  PROCEDURE FormName(VAR pathname: ARRAY OF CHAR;
                     VAR drive: SHORTCARD;
                     VAR currDir: ARRAY OF CHAR);

  BEGIN
    IF Str.Pos(pathname, ":") = MAX(CARDINAL) THEN (* if no drive indicated *)
      drive := GetDrive();                         (* then insert current   *)
      AddDrive(drive, pathname)                    (* drive designation     *)
    ELSE
      drive := SHORTCARD( ORD( CAP(pathname[0]) ) - ORD('A') )
    END;

    GetDir(drive+1, currDir);
    Str.Insert(currDir, "\", 0);

    IF pathname[2] # '\' THEN
      Str.Insert( pathname, "\", 2 );
      IF Str.Length(currDir) > 1 THEN Str.Insert(pathname, currDir, 2) END
    END
  END FormName;

END AltFIO.