Unit FileIO;

{***************************************************************************}

{* Dir                I/O       FILE    integer

{* DirDirs            I/O       FILE    integer

{* DirExists          I/O       FILE

{* DirFiles           I/O       FILE

{* DirKill            I/O       FILE

{* DirKillDef         I/O       FILE    definitely kills the dir

{* DirMake            I/O       FILE

{* FileDataBool       I/O       FILE    bool: true if no IOError

{* FileCopy           I/O       FILE

{* FileCreate         I/O       FILE

{* FileDel            I/O       FILE

{* FileExists         I/O       FILE

{* FileKill           I/O       FILE    integer

{* FileKillDef        I/O       FILE    integer  definitely kills it

{* FileLine           I/O       FILE

{* FileLineCount      I/O       FILE

{* FileLineDel        I/O       FILE

{* FileOpen           I/O       FILE

{* FileSearch         I/O       FILE

{* GetDirFile         I/O       FILE

{* GetDirFileOnly     I/O       FILE

{* GetFileName        I/O       FILE

{* SayFile            I/O       FILE

{* WildCardFormat     I/O       FILE

{***************************************************************************}



interface

{***************************************************************************}

{***************************************************************************}



Function  Dir(DirStr: string): integer;

Function  DirDirs(DirStr: string): integer;

Function  DirExists(DirStr: string): boolean;

procedure DirFiles(SearchStr: string; var Count: integer);

Function  DirKill(DirStr: string): integer;

Function  DirKillDef(DirStr: string): integer;

Function  DirMake(DirStr: string): boolean;

Procedure FileCopy(OriginalFile: string; NewFile: string);

Function  FileCreate(NewFile: string): boolean;

Function  FileDataBool(OpChar: char; FileStr: string; PosNum: longint;

            var BoolVal: boolean): boolean;

procedure FileDel(FileSpec: string; var Code: integer);

function  FileExists(FileStr: string): boolean;

Function  FileExistsMake(FileStr: string): boolean;

Function  FileKill(DeadFile: string): integer;

Function  FileKillDef(DeadFile: string): integer;

Function  FileLine(ModeChar: char; FileStr: string;

            LineNum: integer; var LineStr: string): boolean;

Function  FileLineCount(FileStr: string): integer;

Procedure FileLineDel(FileStr: string; StartNum, StopNum: integer);

Function  FileOpen(ModeChar:char; InFileStr:string;

            var InFile:text): integer;

Function  FileSearch(ModeChar: char; FileStr: string;

            var MatchStr: string): integer;

function  GetDirFile(SearchStr: string): string;

function  GetDirFileOnly(SearchStr: string): string;

procedure GetFileName(var Lead8, Ext: string);

Procedure SayFile(SayFileStr: string);

procedure SplitFileName(InFile: string; var Lead8, Extension: string);



implementation

{***************************************************************************}

{***************************************************************************}

Uses

  Crt,

  Dos,

  Globals,

  IOPorts, {* fix this! this is BBS specific for Say & SayL *}

  Keyboard,

  MiscSubs,

  Video;



const

  TempFile = 'TempFile.TMP';



Function Dir(DirStr: string): integer;

{***************************************************************************}

var

  count: integer;

  S: SearchRec;

begin

  count := 0;

  FindFirst(DirStr, AnyFile, S);

  while DosError <> 18 do

    begin

      writeln(S.Name);

      Inc(Count);

      FindNext(S);

    end;

  Dir := Count;

end;



Function DirDirs(DirStr: string): integer;

{***************************************************************************}

var

  count: integer;

  S: SearchRec;

begin

  count := 0;

  FindFirst(DirStr, AnyFile, S);

  while DosError <> 18 do

    begin

      if (S.Attr and Directory = Directory) and

        ((S.Name <> '.') and (S.Name <> '..')) then

          begin

            if (Count mod 4 = 0) and (Count <> 0) then

              writeln;

            GotoXY((Count mod 4)*20, WhereY);

            write(S.Name);

            Inc(Count);

          end;

      FindNext(S);

    end;

  if count <> 0 then

    writeln;

  DirDirs := Count;

end;



Function DirExists(DirStr: string): boolean;

{***************************************************************************}

var

  S: SearchRec;

begin

  FindFirst(DirStr, Directory, S);

  if S.Name <> '' then

    DirExists := true

  else

    begin

      SayL('Creating '+DirStr+'...');

      {$I-}

      MkDir(DirStr);

      {$I+}

      if IOResult <> 0 then

        DirExists := false

      else

        DirExists := true;

    end;

end;



procedure DirFiles(SearchStr: string; var Count: integer);

{***************************************************************************}

var

  DirInfo: SearchRec;

begin

  writeln('Directory of all "',SearchStr,'".');

  Count := 0;

  FindFirst(SearchStr,AnyFile,DirInfo);

  while DosError = 0 do

    begin

      if DirInfo.Attr <> 16 then

        begin

          GotoXY((Count mod 4)*20, WhereY);

          Inc(Count);

          Write(Count,') ',DirInfo.Name);

          if Factorial(Count, 4) then

            writeln;

        end;

      FindNext(DirInfo);

    end;

  if WhereX <> 1 then

    writeln;

end;



Function  DirKill(DirStr: string): integer;

{***************************************************************************}

begin

  {$I-}

  RmDir(DirStr);

  {$I+}

  DirKill := IOResult;

end;



Function  DirKillDef(DirStr: string): integer;

{***************************************************************************}

var

  DirResult: integer;

  S: SearchRec;

begin

  DirResult := DirKill(DirStr);

  if DirResult = 5 then

    begin

      FindFirst(DirStr+'\*.*', $3F, S);

      repeat

        if S.Attr and $10 = $10 then {* directory *}

          begin

            if (S.Name <> '.') and (S.Name <> '..') then

              DumInt := DirKillDef(DirStr + '\' + S.Name);

          end

        else

          DirResult := FileKillDef(DirStr + '\' + S.Name);

        FindNext(S);

      until DosError = 18; {* no more files *}

      DirResult := DirKill(DirStr);

    end;

  DirKillDef := DirResult;

end;



Function  DirMake(DirStr: string): boolean;

{***************************************************************************}

{* Will create multi-level directories with one call.

{***************************************************************************}

var

  SaveDir: string;

  DirChar: char;

  WorkDir: string;

begin

  GetDir(0, SaveDir);

  while DirStr <> '' do

    begin

      WorkDir := '';

      repeat

        DirChar := DirStr[1];

        DirStr := copy(DirStr, 2, length(DirStr) - 1);

        if DirChar <> '\' then

          WorkDir := WorkDir + DirChar;

      until (DirChar = '\') or (length(DirStr) = 0);

      {$I-}

      MkDir(WorkDir);

      if DirStr <> '' then

        ChDir(WorkDir);

      {$I+}

    end;

  DumInt := IOResult;

  {$I-}

  ChDir(SaveDir);

  {$I+}

  if IOResult = 0 then

    DirMake := true

  else

    DirMake := false;

end;



Procedure FileCopy(OriginalFile: string; NewFile: string);

{***************************************************************************}

var

  Orig,

  NewF: text;

  LineStr: string;

begin

  if FileOpen('R', OriginalFile, Orig) = 0 then

    if FileOpen('W', NewFile, NewF) = 0 then

      begin

        while not(EOF(Orig)) do

          begin

            readln(Orig, LineStr);

            writeln(NewF, LineStr);

          end;

        close(Orig);

        close(NewF);

      end;

end;



Function FileCreate(NewFile: string): boolean;

{***************************************************************************}

var

  NF: text;

begin

  if FileOpen('W', NewFile, NF) = 0 then

    begin

      close(NF);

      FileCreate := true;

    end

  else

    FileCreate := false;

end;



Function FileDataBool(OpChar: char; FileStr: string; PosNum: longint;

           var BoolVal: boolean): boolean;

{***************************************************************************}

var

  Temp: boolean;

  F: file of boolean;

  alpha: longint;

begin

{$I-}

  Temp := false;

  case OpChar of

    'R':

      begin

        Assign(F, FileStr);

        Reset(F);

        if PosNum <= FileSize(F) then

          begin

            Seek(F, PosNum);

            Read(F, BoolVal);

          end;

        Close(F);

        Temp := true;

      end;

    'W':

      begin

        Assign(F, FileStr);

        Reset(F);

        if PosNum <= FileSize(F) then

          begin

            Seek(F, PosNum);

            write(F, BoolVal);

          end

        else

          begin

            DumBool := false;

            Seek(F, FileSize(F));

            for alpha := 1 to PosNum - FileSize(F) do

              write(F, DumBool);

            write(F, BoolVal);

          end;

        Close(F);

      end;

  end; {* case *}

  if IOResult <> 0 then

    Temp := false;

  FileDataBool := Temp;

{$I+}

end;



procedure FileDel(FileSpec: string; var Code: integer);

{***************************************************************************}

{* page 147 Turbo Pascal Programmer's Toolkit by Rugg and Feldman

{***************************************************************************}

var

  Reg: registers;

begin

  FileSpec := FileSpec + chr(0);

  Reg.DX := ofs(FileSpec[1]);

  Reg.DS := seg(FileSpec[1]);

  Reg.AX := $4100;

  msdos(Reg);

  Code := Lo(Reg.Ax);

  if (Reg.Flags and $01) = 0 then

    Code := 0;

end;



function  FileExists(FileStr: string): boolean;

{***************************************************************************}

var

  S:  SearchRec;

begin

  S.Name := '';

  FindFirst(FileStr, AnyFile, S);

  if S.Name = '' then

    FileExists := false

  else

    FileExists := true;

end;



Function  FileExistsMake(FileStr: string): boolean;

{***************************************************************************}

var

  Temp: boolean;

begin

  Temp := FileExists(FileStr);

  if not(Temp) then

    Temp := FileCreate(FileStr);

  FileExistsMake := Temp;

end;



Function FileKill(DeadFile: string): integer;

{***************************************************************************}

var

  DF: text;

begin

  Assign(DF, DeadFile);

  {$I-}

  Erase(DF);

  {$I+}

  FileKill := IOResult;

end;



Function FileKillDef(DeadFile: string): integer;

{***************************************************************************}

var

  DF: text;

begin

  Assign(DF, DeadFile);

  {$I-}

  SetFAttr(DF, 0);

  Erase(DF);

  {$I+}

  FileKillDef := IOResult;

end;



Function  FileLine(ModeChar: char; FileStr: string; LineNum: integer;

            var LineStr: string): boolean;

{***************************************************************************}

var

  alpha: integer;

  InStr: string;

  TF,

  InFile: text;

begin

  ModeChar := upcase(ModeChar);

  if FileOpen('R', FileStr, InFile) <> 0 then

    begin

      if ModeChar = 'O' then

        begin

          if FileCreate(FileStr) then

            begin

              if FileOpen('R', FileStr, InFile) <> 0 then

                begin

                  FileLine := false;

                  exit;

                end;

            end

          else

            begin

              FileLine := false;

              exit;

            end;

        end

      else

        begin

          FileLine := false;

          exit;

        end;

    end;

  if FileOpen('W', TempFile, TF) <> 0 then

    begin

      close(InFile);

      FileLine := false;

      exit;

    end;

  case ModeChar of

    'R': {* Read a line *}

      begin

        close(TF);

        for alpha := 1 to LineNum do

          readln(InFile, LineStr);

        close(InFile);

      end;

    'D': {* Delete *}

      begin

        alpha := 0;

        repeat

          inc(alpha);

          readln(InFile, InStr);

          if alpha <> LineNum then

            writeln(TF, InStr);

        until EOF(InFile);

        close(InFile);

        close(TF);

        Erase(InFile);

        Rename(TF, FileStr);

      end;

    'I': {* Insert *}

      begin

        for alpha := 1 to LineNum - 1 do

          begin

            if EOF(InFile) then

              InStr := ''

            else

              readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        writeln(TF, LineStr);

        while not(EOF(InFile)) do

          begin

            readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        close(TF);

        close(InFile);

        Erase(InFile);

        Rename(TF, FileStr);

      end;

    'O': {* Overwrite *}

      begin

        for alpha := 1 to LineNum - 1 do

          begin

            if EOF(InFile) then

              InStr := ''

            else

              readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        if not(EOF(InFile)) then

          readln(InFile, DumStr);

        writeln(TF, LineStr);

        while not(EOF(InFile)) do

          begin

            readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        close(TF);

        close(InFile);

        Erase(InFile);

        Rename(TF, FileStr);

      end;

    else

      begin

        SayL(Beep+'Function Text Line used improperly!');

        FileLine := false;

        exit;

      end;

  end; {case}

  FileLine := true;

end;



Function  FileLineCount(FileStr: string): integer;

{***************************************************************************}

var

  TempFileLineCount: integer;

  FS: text;

begin

  TempFileLineCount := -1;

  if FileOpen('R', FileStr, FS) = 0 then

    begin

      TempFileLineCount := 0;

      while not(EOF(FS)) do

        begin

          readln(FS);

          inc(TempFileLineCount);

        end;

      close(FS);

    end;

  FileLineCount := TempFileLineCount;

end;



Procedure FileLineDel(FileStr: string; StartNum, StopNum: integer);

{***************************************************************************}

var

  FS,

  TF: text;

  Line: integer;

  InStr: string;

begin

  if (StartNum <= 0) or (StopNum < StartNum) then

    begin

      writeln('No lines deleted from the file ',FileStr,'.');

      exit;

    end;

  Assign(FS, FileStr);

  Reset(FS);

  Assign(TF, TempFile);

  Rewrite(TF);

  Line := 0;

  while not(EOF(FS)) do

    begin

      readln(FS, InStr);

      Inc(Line);

      if (Line < StartNum) or (Line > StopNum) then

        writeln(TF, InStr);

    end;

  close(FS);

  close(TF);

  erase(FS);

  rename(TF, FileStr);

end;



Function FileOpen(ModeChar:char; InFileStr:string; var InFile:text): integer;

{***************************************************************************}

var

  Dir: DirStr;

  Name: NameStr;

  Ext: ExtStr;

  TempFileOpen: integer;

  CheckIO: integer;

begin

  Assign(InFile, InFileStr);

  ModeChar := UpCase(ModeChar);

  {$I-}

  case ModeChar of

    'R': Reset(InFile);

    'W':

      begin

        Rewrite(InFile);

        if IOResult = 3 then

          if FileOpen('P', InFileStr, InFile) = 0 then

            Rewrite(InFile);

      end;

    'A': begin

           Append(InFile);

           CheckIO := IOResult;

           if CheckIO <> 0 then

             begin

               case CheckIO of

                 2: Rewrite(InFile);

                 3:

                   begin

                     DumInt := FileOpen('P', InFileStr, InFile);

                     Rewrite(InFile);

                   end;

                 else

                   Append(InFile);

               end; {case}

             end;

         end;

    'P': {* create Path *}

      begin

        FSplit(InFileStr, Dir, Name, Ext);

        Dir := copy(Dir, 1, length(Dir) - 1);

        DumBool := DirMake(Dir);

      end;

    else

      SayL(Beep+'Function FileOpen improperly used!');

  end; {case}

  {$I+}

  TempFileOpen := IOError;

  if TempFileOpen <> 0 then

    ErrSayL('** Error with "'+InFileStr+'".');

  FileOpen := TempFileOpen;

end;



Function  FileSearch(ModeChar: char; FileStr: string;

            var MatchStr: string): integer;

{***************************************************************************}

{* Modes: 'u'=case insensitive, 'l'=case sensitive

{* Return: -1 if file problem or bad mode, 0 if not found

{***************************************************************************}

var

  TempFileSearch: integer;

  Match: boolean;

  LineStr: string;

  alpha: integer;

  FS: text;

begin

  ModeChar := upcase(ModeChar);

  case ModeChar of

    'U': MatchStr := UpCaseStr(MatchStr);

    'L':

      begin

      end;

    else

      begin

        SayL(Beep+'Bad mode character used with Function FileSearch!');

        FileSearch := -1;

        exit;

      end;

  end; {case}

  TempFileSearch := -1;

  Match := false;

  alpha := 0;

  if FileOpen('R', FileStr, FS) = 0 then

    begin

      TempFileSearch := 0;

      repeat

        inc(alpha);

        readln(FS, LineStr);

        if ModeChar = 'U' then

          begin

            if UpCaseStr(LineStr) = MatchStr then

              begin

                Match := true;

                MatchStr := LineStr;

              end;

          end

        else

          if LineStr = MatchStr then

            Match := true;

      until Match or EOF(FS);

      close(FS);

    end;

  if Match then

    TempFileSearch := alpha;

  FileSearch := TempFileSearch;

end;



Function GetDirFile(SearchStr: string): string;

{***************************************************************************}

var

  Count: integer;

  TempDirFile: string;

  FileOpt: integer;

  DirInfo: SearchRec;

  FileNameGood: boolean;

  Lead8: string;

begin

  TempDirFile := '';

  DirFiles(SearchStr, Count);

  writeln(Count+1,') Input a new file name.');

  AskPos('Which file (1 to '+StrInt(Count+1)+')',Count+1, FileOpt);

  if FileOpt = Count + 1 then

    begin

      repeat

        SplitFileName(SearchStr, DumStr, TempDirFile);

        GetFileName(Lead8, DumStr);

        TempDirFile := Lead8 + '.' + TempDirFile;

        writeln('Creating ',TempDirFile,'...');

        wait;

        FileNameGood := WildCardFormat(SearchStr,TempDirFile);

        if not(FileNameGood) then

          begin

            write(Beep);

            writeln('Must be of ',SearchStr,' format!');

            Wait;

            BackUpLines(5);

          end;

      until FileNameGood;

    end

  else

    begin

      FindFirst(SearchStr, AnyFile, DirInfo);

      for count := 1 to FileOpt do

        begin

          if DirInfo.Attr = 16 then

            count := count - 1

          else

            if count = FileOpt then

              TempDirFile := DirInfo.Name;

          FindNext(DirInfo);

        end;

    end;

  GetDirFile := TempDirFile;

end;



function GetDirFileOnly(SearchStr: string): string;

{***************************************************************************}

var

  Count: integer;

  TempDirFile: string;

  FileOpt: integer;

  DirInfo: SearchRec;

  FileNameGood: boolean;

begin

  TempDirFile := '';

  DirFiles(SearchStr, Count);

  if Count = 0 then

    begin

      Write(Beep);

      writeln;

      writeln('No ',SearchStr,' files found!');

      PoliteHalt;

    end;

  AskPos('Which file (1 to '+StrInt(Count)+')',Count, FileOpt);

  FindFirst(SearchStr, AnyFile, DirInfo);

  for count := 1 to FileOpt do

    begin

      if DirInfo.Attr = 16 then

        count := count - 1

      else

        if count = FileOpt then

          TempDirFile := DirInfo.Name;

      FindNext(DirInfo);

    end;

  GetDirFileOnly := TempDirFile;

end;



procedure GetFileName(var Lead8, Ext: string);

{***************************************************************************}

var

  InStr: string;

  NameGood: boolean;

begin

  repeat

    Ask('File name', InStr);

    SplitFileName(InStr, Lead8, Ext);

    if Lead8 = '' then

      begin

        NameGood := false;

        Write(Beep);

        BackUpLine;

      end

    else

      NameGood := true;

  until NameGood;

end;



Procedure SayFile(SayFileStr: string);

{***************************************************************************}

var

  TheSayFile: text;

  LineStr: string;

begin

  Assign(TheSayFile, SayFileStr);

  {$I-}

  Reset(TheSayFile);

  {$I+}

  if IOGood then

    begin

      clr;

      repeat

        readln(TheSayFile, LineStr);

        Say(LineStr);

        if WhereY >= 22 then

          begin

            wait;

            clr;

          end;

      until EOF(TheSayFile);

    end;

  Close(TheSayFile);

  Wait;

end;



procedure SplitFileName(InFile: string; var Lead8, Extension: string);

{***************************************************************************}

{*  If a non-filename is inputted, Lead8 will contain the first 8 and

{*  Extension will contain the next 3.  The rest will be discarded.

{***************************************************************************}

var

  Dot: integer;

  ExtLen: integer;

begin

  Dot := Pos('.',InFile);

  if Dot > 9 then

    Lead8 := copy(InFile, 1, 8)

  else

    if Dot = 1 then

      Lead8 := ''

    else

      if Dot = 0 then

        Lead8 := copy(InFile, 1, 8)

      else

        Lead8 := copy(InFile, 1, Dot - 1);

  if Dot > 0 then

    begin

      ExtLen := length(InFile) - length(Lead8) - 1;

      if ExtLen > 3 then

        ExtLen := 3;

      Extension := copy(InFile, Dot+1, ExtLen);

    end

  else

    Extension := '';

end;





{***************************************************************************}

{***************************************************************************}

{***************************************************************************}

begin

end.