with ConsAKD; use ConsAKD; with ErroAKD; use ErroAKD; with InteAKD; with StriAK; with TextAKD; use TextAKD; with Directory; with File_IO; package body DiskAKD is --------------------------------------------------------------------------- --------------------------------------------------------------------------- Dummy: File_IO.Transfer_Data; Procedure Append_File( Append_File: in string; In_Str: in string; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- -- Opens the file or creates it and opens it. -- Appends the string. -- Closes the file. --------------------------------------------------------------------------- Append_File_Handle : File_Handle_Type; Temp_Error : Error_DOS_Type; begin DiskAKD.Open_File ( Append_File, Append_File_Handle, Temp_Error, false); if Temp_Error = File_Not_Found then DiskAKD.Open_New_File(Append_File, Append_File_Handle, Error); end if; DiskAKD.Append_File(Append_File_Handle, In_Str, Error); DiskAKD.Close_File(Append_File_Handle, Error); end Append_File; Procedure Append_File( Handle: in File_Handle_Type; In_Str: in string; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- -- Moves the file pointer to the end of the file and adds the string. --------------------------------------------------------------------------- Dummy: long_integer; begin File_IO.Move_File_Pointer(Handle, File_IO.Current_End, 0, Dummy, Error_DOS_Type ( Error ) ); WriteLn(Handle, In_Str, Error); end Append_File; Procedure Close_File( Handle: in File_Handle_Type; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- begin Error := Error_DOS_Type ( File_IO.Close ( Handle ) ); end Close_File; procedure Delete ( File_Name : in out File_Name_Type; Error : out Error_DOS_Type; Path_Name : in string := "" ) is --------------------------------------------------------------------------- -- Accepts wildcards, returns un-wildcarded name in File_Name --------------------------------------------------------------------------- Transfer_Area : Transfer_Data; File_Data : File_Data_Type; Error_Temp : Error_DOS_Type; begin Find_First ( Path_Name & File_Name, Transfer_Area, File_Data, Error_Temp ); if Error_Temp = OK then File_Name := File_Data.Name; Error := Error_DOS_Type ( File_IO.Delete ( Path_Name & File_Name ) ); else Error := Error_Temp; end if; end Delete; procedure Delete ( Path_File_Name : in string; Error : out Error_DOS_Type ) is --------------------------------------------------------------------------- begin Error := Error_DOS_Type ( File_IO.Delete ( Path_File_Name ) ); end Delete; procedure DelSub ( Error : out Error_DOS_Type; Dead_File : in File_Name_Type; Dir_Name : in Dir_Name_Type := "" ) is --------------------------------------------------------------------------- Error_Temp : Error_DOS_Type; File_Data : File_Data_Type; File_Name : File_Name_Type; Transfer_Area : Transfer_Data; begin Find_First ( Dir_Name & Dead_File, Transfer_Area, File_Data, Error_Temp ); loop if Error_Temp = No_More_Files then exit; elsif Error_Temp /= OK then Error := Error_Temp; return; end if; File_Name := File_Data.Name; Put ( Dir_Name & StriAK.Upcase ( StriAK.Trim_White_Space ( File_Name ) ) ); Delete ( File_Name, Error_Temp, Dir_Name ); if Error_Temp /= OK then Put_Line ( " " & Error_DOS_Type'image ( Error_Temp ) ); else Put_Line ( "" ); end if; Find_Next ( Transfer_Area, File_Data, Error_Temp ); end loop; Find_First ( Dir_Name & "*.*", Transfer_Area, File_Data, Error_Temp, Search_Attributes => ( File_IO.subdirectory => true, others => false ) ); loop exit when Error_Temp /= OK; if ( File_Data.Name ( 1 ) /= '.' ) and File_Data.Attributes ( File_IO.Subdirectory ) then DelSub ( Error_Temp, Dead_File, Dir_Name & StriAK.Trim_White_Space ( File_Data.Name ) & "\" ); exit when Error_Temp /= OK; end if; Find_Next ( Transfer_Area, File_Data, Error_Temp ); end loop; if Error_Temp = No_More_Files then Error_Temp := OK; end if; Error := Error_Temp; end DelSub; procedure Demo is ---------------------------------------------------------------------- Template : string ( 1..12 ) := "AdaKit.Exe "; Nth : positive := 1; File_Data : File_Data_Type; Error : Error_DOS_Type; begin Put_Line ( Copyright ); Put_Line ( "Demonstration of Find_Nth function." ); New_Line; Ask ( Template, "File name with wildcards (Template) ", Template ); Nth := InteAKD.Ask_Pos ( "Which one (Nth)? ", Nth ); Find_Nth ( Template, Nth, File_Data, Error ); if Error /= OK then Put_Line ( Error_DOS_Type'image ( Error ) ); else Put_Line ( File_Data.Name ); end if; Pause; end Demo; procedure Dir ( Template: in string; Count: out natural ) is --------------------------------------------------------------------------- Err: Error_DOS_Type; File_Info: File_IO.File_Data; TempCount: natural := 0; Transfer_Area: File_IO.Transfer_Data; begin File_IO.Find_First ( Template, Transfer_Area, File_Info, Error_DOS_Type ( Err ) ); while Err = OK loop TempCount := TempCount + 1; Put_Line(natural'image(TempCount) & ") " & File_Info.Name); File_IO.Find_Next ( Transfer_Area, File_Info, Error_DOS_Type ( Err ) ); end loop; Count := TempCount; end Dir; function Dir_Delete ( Dir_Name: in Dir_Name_Type ) return Error_DOS_Type is --------------------------------------------------------------------------- -- Deletes the files in the directory but not the sub-directory. -- Includes hidden, read-only, and system files. -- Returns OK when done unless error occurs. --------------------------------------------------------------------------- Error: Error_DOS_Type; File_Data: File_Data_Type; begin loop Find_Nth ( Dir_Name & "\*.*", 1, File_Data, Error, ( File_IO.Read_Only => true, File_IO.Hidden => true, File_IO.System => true, File_IO.Volume_Label => false, File_IO.Subdirectory => false, File_IO.Archive => true ) ); exit when Error /= OK; Error := Error_DOS_Type ( File_IO.Set_Attributes ( Dir_Name & '\' & File_Data.Name, ( others => false ) ) ); if Error /= OK then return Error; end if; Error := Error_DOS_Type ( File_IO.Delete ( Dir_Name & '\' & File_Data.Name ) ); if Error /= OK then return Error; end if; end loop; if Error = No_More_Files then return OK; else return Error; end if; end Dir_Delete; function File_Exists ( File_Name : in string ) return boolean is ---------------------------------------------------------------------- Dummy : File_Data_Type; Error : Error_DOS_Type; begin Find_Nth ( File_Name, 1, Dummy, Error ); if Error = OK then return true; elsif Error = No_More_Files then return false; else raise Name_Error; end if; end File_Exists; Function File_Picked( Template: in string) return string is --------------------------------------------------------------------------- -- Returns " " if no file is successfully picked. --------------------------------------------------------------------------- Count: natural; Err: Error_DOS_Type; File_Info: File_IO.File_Data; NoFile: constant string(1..12) := (others => ' '); Transfer_Area: File_IO.Transfer_Data; begin DiskAKD.Dir(Template, Count); if Count = 0 then Put_Line("There are no " & Template & " files in the default directory."); ConsAKD.Pause; return NoFile; end if; Put_Line ( "" ); Count := InteAKD.Ask_Nat ( "Please choose a file ", Count ); DiskAKD.Find_Nth(Template, Count, File_Info, Err); if Err = OK then return File_Info.Name; else return NoFile; end if; exception when others => Notify("DiskAKD.File_Picked"); raise; end File_Picked; procedure Find_First ( Template : in string; Transfer_Area : in out Transfer_Data; File_Data : out File_Data_Type; Error : out Error_DOS_Type; Search_Attributes : in File_Attributes := ( others => false ) ) is --------------------------------------------------------------------------- begin File_IO.Find_First ( Template, Transfer_Area, File_Data, Error_DOS_Type ( Error ), Search_Attributes ); end Find_First; procedure Find_Next ( Transfer_Area : in out Transfer_Data; File_Data : out File_Data_Type; Error : out Error_DOS_Type ) is --------------------------------------------------------------------------- begin File_IO.Find_Next ( Transfer_Area, File_Data, Error_DOS_Type ( Error ) ); end Find_Next; procedure Find_Nth ( Template : in string; Nth : in positive; File_Data : out File_Data_Type; Error : out Error_DOS_Type; Search_Attributes : in File_IO.File_Attributes := ( others => false ) ) is --------------------------------------------------------------------------- -- Error = ??? when file not found. --------------------------------------------------------------------------- Transfer_Area: File_IO.Transfer_Data; begin Find_First ( Template, Transfer_Area, File_Data, Error, Search_Attributes ); for index in 2..Nth loop Find_Next ( Transfer_Area, File_Data, Error ); end loop; exception when others => Notify("DiskAKD.Find_Nth"); raise; end Find_Nth; function Move ( From : in string; To : in string ) return Error_DOS_Type is --------------------------------------------------------------------------- begin return Rename ( From, To ); end Move; Procedure Open_File ( File_Name: in string; Handle: out File_Handle_Type; Error: out Error_DOS_Type; Warn: in boolean := true ) is --------------------------------------------------------------------------- TempError: Error_DOS_Type; begin File_IO.Open ( File_Name, Handle, Error_DOS_Type ( TempError ) ); if Warn and ( TempError /= OK ) then ErroAKD.Warn ( Error_DOS_Type'image ( TempError ) ); end if; Error := TempError; end Open_File; Procedure Open_New_File ( File_Name: in string; Handle: out File_Handle_Type; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- -- If file already exists, it is overwritten. --------------------------------------------------------------------------- TempError: Error_DOS_Type; begin File_IO.Create ( File_Name, Handle, Error_DOS_Type ( TempError)); if TempError /= OK then Warn(Error_DOS_Type'image(TempError)); end if; Error := TempError; exception when others => Notify("DiskAKD.Open_New_File"); raise; end Open_New_File; function Prune ( Dir_Name: in Dir_Name_Type ) return Error_DOS_Type is --------------------------------------------------------------------------- -- Prunes directories even if they contain sub-directories, hidden, -- read-only, and system files. --------------------------------------------------------------------------- Dir_Data: File_Data_Type; Error: Error_DOS_Type; File_Data: File_Data_Type; begin Error := Dir_Delete ( Dir_Name ); if Error /= OK then return Error; end if; loop Find_Nth ( Dir_Name & "\*.*", 1, Dir_Data, Error, ( File_IO.subdirectory => true, others => false ) ); exit when Error /= OK; Error := Prune ( Dir_Name & '\' & Dir_Data.Name ); if Error /= OK then return Error; end if; end loop; if Error /= No_More_Files then return Error; end if; return Error_DOS_Type ( Directory.Remove ( Dir_Name ) ); end Prune; Procedure ReadLn( Handle: in File_Handle_Type; OutStr: out string; Is_End_of_File: out boolean; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- -- If OutStr < Disk string, all of Disk string is read anyway. --------------------------------------------------------------------------- Bytes_Read: natural; Str_Len: natural := 0; Temp_OutStr: string(OutStr'first..OutStr'last); TempStr: string(OutStr'first..OutStr'last+1); begin Is_End_of_File := false; loop File_IO.Read ( Handle, 1, TempStr(Str_Len+1)'address, Bytes_Read, Error_DOS_Type ( Error ) ); if Bytes_Read = 0 then Is_End_Of_File := true; exit; end if; if TempStr(Str_Len+1) = ASCII.CR then File_IO.Read ( Handle, 1, TempStr(Str_Len+1)'address, Bytes_Read, Error_DOS_Type ( Error ) ); exit; end if; if Str_Len < OutStr'last then Str_Len := Str_Len + 1; end if; end loop; for index in (Str_Len+1..OutStr'last) loop TempStr(index) := ' '; end loop; StriAK.Copy(Temp_OutStr, TempStr, 1, Temp_OutStr'last); OutStr := Temp_OutStr; exception when others => Notify("DiskAKD.ReadLn"); raise; end ReadLn; function Rename ( From : in string; To : in string ) return Error_DOS_Type is --------------------------------------------------------------------------- begin return Error_DOS_Type ( File_IO.Rename ( Old_Name => From, New_Name => To )); end Rename; Procedure Show_File ( File_Name : in string; Error : out Error_DOS_Type; Warn : in boolean := true; Clear_Screen : in boolean := true; End_Pause : in boolean := true ) is --------------------------------------------------------------------------- Error_Temp : Error_DOS_Type; Handle: File_Handle_Type; In_Str: string ( 1..80 ); Is_EOF: boolean; Line_Count: natural := 0; begin Open_File ( File_Name, Handle, Error_Temp, Warn ); Error := Error_Temp; if Error_Temp /= OK then return; end if; if Clear_Screen then ConsAKD.Clear_Screen; end if; loop ReadLn(Handle, In_Str, Is_EOF, Error); Put(In_Str); Line_Count := Line_Count + 1; if (Line_Count = 25 - 1) and not(Is_EOF) then Pause; ConsAKD.Clear_Screen; Line_Count := 0; end if; exit when Is_EOF; end loop; Close_File ( Handle, Error ); if End_Pause then Pause; end if; end Show_File; Procedure Split_File_Name( Original_Name: in string; First_8: out string; Extension: out string) is --------------------------------------------------------------------------- Count: positive range 1..12; Temp_8: string(1..8) := " "; Temp_4: string(1..4) := ". "; begin for count in 1..8 loop exit when Original_Name(count) = '.'; Temp_8(count) := Original_Name(count); end loop; First_8 := Temp_8; for count in 1..12 loop exit when Original_Name(count) = '.'; end loop; for index in 2..4 loop if count+index-1 <= 12 then Temp_4(index) := Original_Name(count+index - 1); end if; end loop; Extension := Temp_4; exception when others => Notify("DiskAKD.Split_File_Name"); raise; end Split_File_Name; Procedure Write( Handle: in File_Handle_Type; InStr: in string; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- Bytes_Written: natural; begin File_IO.Write(Handle, InStr'last, InStr(1)'address, Bytes_Written, Error_DOS_Type ( Error ) ); end Write; Procedure WriteLn( Handle: in File_Handle_Type; InStr: in string; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- LineStr: string(1..InStr'last+2); begin LineStr := InStr & ASCII.CR & ASCII.LF; Write(Handle, LineStr, Error); end WriteLn; Procedure Write_Both( Handle: in File_Handle_Type; InStr: in string; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- begin Put(InStr); Write(Handle, InStr, Error); end Write_Both; Procedure WriteLn_Both( Handle: in File_Handle_Type; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- begin WriteLn_Both( Handle, "", Error); end WriteLn_Both; Procedure WriteLn_Both( Handle: in File_Handle_Type; InStr: in string; Error: out Error_DOS_Type) is --------------------------------------------------------------------------- begin Put_Line(InStr); WriteLn(Handle, InStr, Error); end WriteLn_Both; --------------------------------------------------------------------------- --------------------------------------------------------------------------- end DiskAKD;