DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 81997 (0x1404d) Types: TextFile Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00 └─ ⟦0c20f784e⟧ »DATA« └─⟦1abbe589f⟧ └─⟦49e7f20b9⟧ └─⟦this⟧
--/ if R1000 then with Directory_Tools; --/ elsif TeleGen2 and then Unix then --// with Error_Messages; -- Unix error codes --// with File_Ops; -- Unix file operations --// with Integer_Text_Io; --// with Process_Control; -- Unix process controls --// with System_Calls; -- Unix system calls --// with Unix_Types; -- Unix system types --// use Unix_Types; --/ end if; with Text_Io; with Unchecked_Deallocation; with Xlbt_Arithmetic; use Xlbt_Arithmetic; with Xlbt_String; use Xlbt_String; package body Test_Io is ------------------------------------------------------------------------------ -- X Library Testing -- -- Test_Io - Basic I/O facilities for the tests. ------------------------------------------------------------------------------ -- Copyright 1990 - 1990 by Rational, Santa Clara, California. -- -- All Rights Reserved. -- -- Permission to use, copy, modify, and distribute this software and its -- documentation for any purpose and without fee is hereby granted, -- provided that the above copyright notice(s) appear in all copies and that -- both that copyright notice(s) and this permission notice appear in -- supporting documentation, and that the name of Rational not be used in -- advertising or publicity pertaining to distribution of the software -- without specific, written prior permission. -- -- Rational disclaims all warranties with regard to this software, including -- all implied warranties of merchantability and fitness, in no event shall -- Rational be liable for any special, indirect or consequential damages or -- any damages whatsoever resulting from loss of use, data or profits, whether -- in an action of contract, negligence or other tortious action, arising out -- of or in connection with the use or performance of this software. ------------------------------------------------------------------------------ --/ if R1000 then package Integer_Text_Io is new Text_Io.Integer_Io (Integer); --/ end if; ------------------------------------------------------------------------------ -- File_List - List of all open output files. ------------------------------------------------------------------------------ type File_List_Rec; type File_List is access File_List_Rec; type File_List_Rec is record Next : File_List; File : Text_Io.File_Type; Duplicate : Boolean; end record; --/ if Enable_Deallocation then pragma Enable_Deallocation (File_List); --/ end if; procedure Free_File_List is new Unchecked_Deallocation (File_List_Rec, File_List); Current : File_List := null; ------------------------------------------------------------------------------ -- File_Line - Line of a file we are diff'ing. ------------------------------------------------------------------------------ type String_Pointer is access String; --/ if Enable_Deallocation then pragma Enable_Deallocation (String_Pointer); --/ end if; procedure Free_String_Pointer is new Unchecked_Deallocation (String, String_Pointer); type File_Line_Rec is record Line : String_Pointer; Hash : S_Long; Eop : Boolean; Blank : Boolean; end record; type File_Line is access File_Line_Rec; --/ if Enable_Deallocation then pragma Enable_Deallocation (File_Line); --/ end if; type File_Line_Array is array (S_Natural range <>) of File_Line; type File_Line_List is access File_Line_Array; --/ if Enable_Deallocation then pragma Enable_Deallocation (File_Line_List); --/ end if; procedure Free_File_Line is new Unchecked_Deallocation (File_Line_Rec, File_Line); procedure Free_File_Line_Array is new Unchecked_Deallocation (File_Line_Array, File_Line_List); ------------------------------------------------------------------------------ -- Wildcards ------------------------------------------------------------------------------ type File_Name_Rec; type File_Name is access File_Name_Rec; type File_Name_Rec is record Next : File_Name; Name : String_Pointer; end record; --/ if Enable_Deallocation then pragma Enable_Deallocation (File_Name); --/ end if; procedure Free_File_Name_Rec is new Unchecked_Deallocation (File_Name_Rec, File_Name); Name_List : File_Name; --\f function To_String (Str : X_String) return String is Stro : String (1 .. Str'Length) := Xlbt_String.To_String (Str); begin for I in Stro'Range loop if Character'Pos (Stro (I)) not in 32 .. 127 then return Stro (Stro'First .. I - 1) & '\' & Natural'Image (Character'Pos (Stro (I))) & '\' & To_String (Str (Str'First + S_Natural (I) .. Str'Last)); end if; end loop; return Stro; end To_String; --\f procedure Free_File_Name (Name : in out File_Name) is ------------------------------------------------------------------------------ -- List - Specfies the list to deallocatd -- -- We deallocate all elements of the list and then the list itself. ------------------------------------------------------------------------------ begin Free_String_Pointer (Name.Name); Free_File_Name_Rec (Name); end Free_File_Name; --\f procedure Free_File_Line_List (List : in out File_Line_List) is ------------------------------------------------------------------------------ -- List - Specfies the list to deallocatd -- -- We deallocate all elements of the list and then the list itself. ------------------------------------------------------------------------------ begin for I in List'Range loop if List (I) /= null then Free_String_Pointer (List (I).Line); Free_File_Line (List (I)); end if; end loop; Free_File_Line_Array (List); end Free_File_Line_List; --\f procedure Put_Aux (Msg : String) is ------------------------------------------------------------------------------ -- Msg - Specifies the ::: error message to put out. -- -- Put out "::: " and Msg to all active outputs regardless of Duplicate flag. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put (File.File, "::: "); Text_Io.Put_Line (File.File, Msg); File := File.Next; end loop; Text_Io.Put (Text_Io.Standard_Output, "::: "); Text_Io.Put_Line (Text_Io.Standard_Output, Msg); end Put_Aux; --\f procedure Put_Error (Msg : String) is ------------------------------------------------------------------------------ -- Msg - Specifies the *** error message to put out. -- -- Put out "*** " and Msg to all active outputs regardless of Duplicate flag. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put (File.File, "*** "); Text_Io.Put_Line (File.File, Msg); File := File.Next; end loop; Text_Io.Put (Text_Io.Standard_Output, "*** "); Text_Io.Put_Line (Text_Io.Standard_Output, Msg); end Put_Error; --\f procedure Put_Exception (Msg : String) is ------------------------------------------------------------------------------ -- Msg - Specifies the %%% error message to put out. -- -- Put out "%%% " and Msg to all active outputs regardless of Duplicate flag. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put (File.File, "*** "); Text_Io.Put_Line (File.File, Msg); File := File.Next; end loop; Text_Io.Put (Text_Io.Standard_Output, "*** "); Text_Io.Put_Line (Text_Io.Standard_Output, Msg); end Put_Exception; --\f procedure Push_Output (File : String; Duplicate : Boolean := True) is ------------------------------------------------------------------------------ -- File - Specifies the name of the new output file -- Duplicate - Specifies TRUE if output should go to all stacked outputs -- -- Opens the file for writing and sets it so that it is used for future output. -- -- Duplicate => FALSE will block normal output from duplication in "outer" -- log files. If another Push is done with Duplicate => TRUE then output -- will go to that file and this one but no further because this one has -- Duplicate => FALSE which blocks further output. -- -- Put_Error and Put_Exception ignore the Duplicate flag. ------------------------------------------------------------------------------ New_File : File_List := new File_List_Rec; begin ----Create/Open the new output file. begin Text_Io.Create (New_File.File, Text_Io.Out_File, File); New_File.Duplicate := Duplicate; exception when others => begin Text_Io.Open (New_File.File, Text_Io.Out_File, File); exception when others => Free_File_List (New_File); Put_Error ("Failed to open output file [" & File & "]."); raise; end; end; ----Link the new file onto our list of files and make it the current output. New_File.Next := Current; Current := New_File; Text_Io.Set_Output (New_File.File); end Push_Output; --\f procedure Pop_Output is ------------------------------------------------------------------------------ -- Closes the current output file and reverts to the previous output file. -- Raises Constraint_Error if there was no previous file. ------------------------------------------------------------------------------ Old_File : File_List; begin ----Make sure that we have an old file. if Current = null then raise Constraint_Error; end if; ----Close the old file. Text_Io.New_Line (Current.File); Text_Io.Put_Line (Current.File, "End of log."); Text_Io.Close (Current.File); ----Remove the old file from the list and free the storage. Old_File := Current; Current := Current.Next; Free_File_List (Old_File); ----Set the current output file. if Current /= null then Text_Io.Set_Output (Current.File); else Text_Io.Set_Output (Text_Io.Standard_Output); end if; end Pop_Output; --\f procedure Section (Name : String) is ------------------------------------------------------------------------------ -- Name - Specifies the name of a "section" in the log file -- -- Called within tests so that we can log "where we are" while running a test. -- Some tests will have many "parts" and each part will start by identifying -- itself to the log. This helps when initially tracking down bugs that show -- up when running the regression tests. ------------------------------------------------------------------------------ begin New_Line; Put ("=== Test Section => "); Put_Line (Name); New_Line; end Section; --\f procedure New_Line (Spacing : Positive := 1) is ------------------------------------------------------------------------------ -- Spacing - Specifies the number of new-lines to produce -- -- Called to go to a new line in the log file. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.New_Line (File.File, Text_Io.Positive_Count (Spacing)); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.New_Line (Text_Io.Standard_Output, Text_Io.Positive_Count (Spacing)); end New_Line; --\f procedure Set_Col (To : Positive) is ------------------------------------------------------------------------------ -- To - Specifies the column to go to, 1..N -- -- Used to put out column information in the log file. Helps when you want -- various things to line up in the log. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Set_Col (File.File, Text_Io.Positive_Count (To)); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.Set_Col (Text_Io.Standard_Output, Text_Io.Positive_Count (To)); end Set_Col; --\f procedure Put (Ch : Character) is ------------------------------------------------------------------------------ -- Ch - Specifies the character to put out -- -- Used to put one character into the log. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put (File.File, Ch); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.Put (Text_Io.Standard_Output, Ch); end Put; --\f procedure Put (Str : String) is ------------------------------------------------------------------------------ -- Str - Specifies the string to put out -- -- Used to put a string into the log. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put (File.File, Str); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.Put (Text_Io.Standard_Output, Str); end Put; --\f procedure Put_Line (Str : String) is ------------------------------------------------------------------------------ -- Str - Specifies the string to put out -- -- Used to put a string into the log and ends it in a new-line. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put_Line (File.File, Str); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.Put_Line (Text_Io.Standard_Output, Str); end Put_Line; --\f procedure Putx (Str : X_String) is ------------------------------------------------------------------------------ -- Str - Specifies the string to put out -- -- Used to put a string into the log. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put (File.File, To_String (Str)); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.Put (Text_Io.Standard_Output, To_String (Str)); end Putx; --\f procedure Putx_Line (Str : X_String) is ------------------------------------------------------------------------------ -- Str - Specifies the string to put out -- -- Used to put a string into the log and ends it in a new-line. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Text_Io.Put_Line (File.File, To_String (Str)); if not File.Duplicate then return; end if; File := File.Next; end loop; Text_Io.Put_Line (Text_Io.Standard_Output, To_String (Str)); end Putx_Line; --\f procedure Put (Int : Integer; Width : Natural := 1; Base : Positive := 10) is ------------------------------------------------------------------------------ -- Int - Specifies the integer value -- Width - Specifies the width of the output -- Base - Specifies the base of the output -- -- Used to put an integer into the log; base 10. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Integer_Text_Io.Put (File.File, Int, Text_Io.Field (Width), Text_Io.Number_Base (Base)); if not File.Duplicate then return; end if; File := File.Next; end loop; Integer_Text_Io.Put (Text_Io.Standard_Output, Int, Text_Io.Field (Width), Text_Io.Number_Base (Base)); end Put; --\f procedure Hex (Int : Integer; Width : Natural := 1; Base : Positive := 16) is ------------------------------------------------------------------------------ -- Int - Specifies the integer value -- Width - Specifies the width of the output -- Base - Specifies the base of the output -- -- Used to put an integer into the log; base 16. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop Integer_Text_Io.Put (File.File, Int, Text_Io.Field (Width), Text_Io.Number_Base (Base)); if not File.Duplicate then return; end if; File := File.Next; end loop; Integer_Text_Io.Put (Text_Io.Standard_Output, Int, Text_Io.Field (Width), Text_Io.Number_Base (Base)); end Hex; --\f procedure Put (Ul : S_Long; Width : Natural := 1; Base : Positive := 10) is ------------------------------------------------------------------------------ -- Int - Specifies the S_Long value -- Width - Specifies the width of the output -- Base - Specifies the base of the output -- -- Used to put an S_Long into the log; base 10. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop S_Long_Io.Put (File.File, Ul, Text_Io.Field (Width), Text_Io.Number_Base (Base)); if not File.Duplicate then return; end if; File := File.Next; end loop; S_Long_Io.Put (Text_Io.Standard_Output, Ul, Text_Io.Field (Width), Text_Io.Number_Base (Base)); end Put; --\f procedure Hex (Ul : S_Long; Width : Natural := 1; Base : Positive := 16) is ------------------------------------------------------------------------------ -- Int - Specifies the S_Long value -- Width - Specifies the width of the output -- Base - Specifies the base of the output -- -- Used to put an S_Long into the log; base 16. ------------------------------------------------------------------------------ File : File_List := Current; begin while File /= null loop S_Long_Io.Put (File.File, Ul, Text_Io.Field (Width), Text_Io.Number_Base (Base)); if not File.Duplicate then return; end if; File := File.Next; end loop; S_Long_Io.Put (Text_Io.Standard_Output, Ul, Text_Io.Field (Width), Text_Io.Number_Base (Base)); end Hex; --\f function Append_File_Extension (File : String; Extension : String) return String is ------------------------------------------------------------------------------ -- File - Specifies the basic name of the file, eg. "foobar". -- Extension - Specifies the extension to give to the file, eg. "log". -- -- Adds the Extension to the File with the appropriate system-dependent -- character(s) in between. Eg. "foobar.log" or "foobar_log" ------------------------------------------------------------------------------ begin --/ if R1000 then return File & '_' & Extension; --/ elsif Unix then --// --// return File & '.' & Extension; --// --/ else --// --// return need_something_here; --// --/ end if; end Append_File_Extension; --\f function File_Context (File : String) return String is ------------------------------------------------------------------------------ -- File - Specifies a file name -- -- Returns the path portion of the name. Returns something like "$" or "." -- for files that have no explicit path. ------------------------------------------------------------------------------ begin --/ if R1000 then declare Prefix : constant String := Directory_Tools.Naming.Prefix (File); begin if Prefix = "" then return "$"; else return Directory_Tools.Naming.Prefix (File); end if; end; --/ elsif Unix then --// --// for I in reverse File'Range loop --// if File (I) = '/' then --// return File (File'First .. I - 1); --// end if; --// end loop; --// return "."; --// --/ else --// --// Need_Something_Here; --// --/ end if; end File_Context; --\f --/ if R1000 then procedure File_Delete (File : String) is ------------------------------------------------------------------------------ -- File - Specifies the file to delete -- -- Called to delete a particular file. ------------------------------------------------------------------------------ Handle : Directory_Tools.Object.Handle; Status : Directory_Tools.Object.Error_Code; begin ----First we locate the object. Handle := Directory_Tools.Naming.Resolution (File); if Directory_Tools.Object.Is_Bad (Handle) then Put_Error ("Could not find [" & File & "] to delete it."); Put_Error ("Error: " & Directory_Tools.Object.Message (Handle)); raise Test_Io_Error; end if; ----Second we delete the object. Directory_Tools.Any_Object.Delete (Handle, Status); if Directory_Tools.Object.Is_Bad (Status) then Put_Error ("Could not delete [" & File & "]."); Put_Error ("Error: " & Directory_Tools.Object.Message (Handle)); raise Test_Io_Error; end if; end File_Delete; --/ end if; -- R1000 --\f --/ if TeleGen2 and then Unix then --// --// procedure File_Delete (File : String) is --// ------------------------------------------------------------------------------ --// -- File - Specifies the file to delete --// -- --// -- Called to delete a particular file. --// ------------------------------------------------------------------------------ --// begin --// --// File_Ops.Unlink (File); --// --// end File_Delete; --// --/ end if; -- TeleGen2 and then Unix --\f function File_Exists (File : String) return Boolean is ------------------------------------------------------------------------------ -- File - Specifies the name of the file to check for -- -- Called to check to see whether or not a file exists and is readable. ------------------------------------------------------------------------------ Old_File : Text_Io.File_Type; begin begin Text_Io.Open (Old_File, Text_Io.In_File, File); Text_Io.Close (Old_File); return True; exception when others => return False; end; end File_Exists; --\f procedure Read_Line (File : Text_Io.File_Type; Line : out String; Linei : out Natural; Eop : out Boolean; Eof : out Boolean) is ------------------------------------------------------------------------------ -- File - Specifies the file to read -- Line - Receives the next line of input -- Linei - Receives the length of the next line -- Eop - Receives TRUE if this line is the last line of a page -- Eof - Receives TRUE if we just encountered EOF and Line is empty -- -- Called to read the next line of input from a file. ------------------------------------------------------------------------------ begin Text_Io.Get_Line (File, Line, Linei); Eop := Text_Io.End_Of_Page (File); Eof := False; exception when Text_Io.End_Error => Linei := 0; Eop := False; Eof := True; end Read_Line; --\f function Equal_Uc (Str1 : String; Str2 : String) return Boolean is ------------------------------------------------------------------------------ -- Str1 - Specifies the first string -- Str2 - Specifies the second string -- -- Called to compare two strings without regard to the case of the strings. -- Returns TRUE if they are equal. ------------------------------------------------------------------------------ C1 : Character; C2 : Character; begin if Str1'Length /= Str2'Length then return False; end if; for I in reverse Natural range 0 .. Str1'Length - 1 loop C1 := Str1 (Str1'First + I); C2 := Str2 (Str2'First + I); if C1 /= C2 then if C1 in 'a' .. 'z' then if C2 in 'A' .. 'Z' then ----C1 and C2 are both letters. if Character'Pos (C1) /= Character'Pos (C2) - (Character'Pos ('A') - Character'Pos ('a')) then return False; end if; else ----C1 is a letter but C2 is not. return False; end if; elsif C1 in 'A' .. 'Z' then if C2 in 'a' .. 'z' then ----C1 and C2 are both letters. if Character'Pos (C1) /= Character'Pos (C2) - (Character'Pos ('a') - Character'Pos ('A')) then return False; end if; else ----C1 is a letter but C2 is not. return False; end if; else ----C1 is not a letter and C1 /= C2. return False; end if; end if; end loop; return True; end Equal_Uc; --\f function Is_Blank (Str : String) return Boolean is ------------------------------------------------------------------------------ -- Str - Specifies the string to check -- -- Returns TRUE if Str is empty or contains only ' ' and/or Ascii.Ht. ------------------------------------------------------------------------------ C : Character; begin for I in Str'Range loop C := Str (I); if C /= ' ' and then C /= Ascii.Ht then return False; end if; end loop; return True; end Is_Blank; --\f function Files_Equal (File1 : String; File2 : String; Ignore_Case : Boolean; Ignore_Blank_Lines : Boolean) return Boolean is ------------------------------------------------------------------------------ -- File1 - Specifies the name of the first file -- File2 - Specifies the name of the second file -- -- We do a "fast" comparison of the two files. Our only concern is 'equality'. -- call the File_Difference routine for a diff output. ------------------------------------------------------------------------------ F1 : Text_Io.File_Type; F2 : Text_Io.File_Type; Result : Boolean := False; Line1 : String (1 .. 1024); Line2 : String (1 .. 1024); Line1i : Natural; Line2i : Natural; Eop1 : Boolean; Eop2 : Boolean; Eof1 : Boolean := False; Eof2 : Boolean := False; begin ----Open the files for reading. begin Text_Io.Open (F1, Text_Io.In_File, File1); exception when others => Put_Error ("Could not open file to compare [" & File1 & "}."); return False; end; begin Text_Io.Open (F2, Text_Io.In_File, File2); exception when others => Put_Error ("Could not open file to compare [" & File2 & "}."); Text_Io.Close (F1); return False; end; ----Loop reading lines until we get to something that is different. if Ignore_Blank_Lines then ----We are ignoring blank lines and case differences. if Ignore_Case then loop loop Read_Line (F1, Line1, Line1i, Eop1, Eof1); if Eof1 or else not Is_Blank (Line1 (1 .. Line1i)) then exit; end if; end loop; loop Read_Line (F2, Line2, Line2i, Eop2, Eof2); if Eof2 or else not Is_Blank (Line2 (1 .. Line2i)) then exit; end if; end loop; if (Line1 (1 .. Line1i) /= Line2 (1 .. Line2i) and then not Equal_Uc (Line1 (1 .. Line1i), Line2 (1 .. Line2i))) or else Eop1 /= Eop2 or else Eof1 /= Eof2 then Result := False; exit; elsif Eof1 then Result := True; exit; end if; end loop; ----We are ignoring blank lines but not case differences. else loop loop Read_Line (F1, Line1, Line1i, Eop1, Eof1); if Eof1 or else not Is_Blank (Line1 (1 .. Line1i)) then exit; end if; end loop; loop Read_Line (F2, Line2, Line2i, Eop2, Eof2); if Eof2 or else not Is_Blank (Line2 (1 .. Line2i)) then exit; end if; end loop; if Line1 (1 .. Line1i) /= Line2 (1 .. Line2i) or else Eop1 /= Eop2 or else Eof1 /= Eof2 then Result := False; exit; elsif Eof1 then Result := True; exit; end if; end loop; end if; ----We are not ignoring blank lines. else ----We are not ignoring blank lines but we are ignoring case differences. if Ignore_Case then loop Read_Line (F1, Line1, Line1i, Eop1, Eof1); Read_Line (F2, Line2, Line2i, Eop2, Eof2); if (Line1 (1 .. Line1i) /= Line2 (1 .. Line2i) and then not Equal_Uc (Line1 (1 .. Line1i), Line2 (1 .. Line2i))) or else Eop1 /= Eop2 or else Eof1 /= Eof2 then Result := False; exit; elsif Eof1 then Result := True; exit; end if; end loop; ----We are not ignoring blank lines or case differences. else loop Read_Line (F1, Line1, Line1i, Eop1, Eof1); Read_Line (F2, Line2, Line2i, Eop2, Eof2); if Line1 (1 .. Line1i) /= Line2 (1 .. Line2i) or else Eop1 /= Eop2 or else Eof1 /= Eof2 then Result := False; exit; elsif Eof1 then Result := True; exit; end if; end loop; end if; end if; ----Close the files and return our result. Text_Io.Close (F1); Text_Io.Close (F2); return Result; exception when others => Put_Line ("%%% Unexpected exception in Text_Io.Files_Equal?"); Text_Io.Close (F1); Text_Io.Close (F2); return False; end Files_Equal; --\f function Hash (Str : String; Ignore_Case : Boolean) return S_Long is ------------------------------------------------------------------------------ -- Str - Specifies the string to hash -- Ignore_Case - Specifies TRUE if we are ignoring case -- -- Computes a hash function for a string. Could overflow for very long strings -- but lines are limited to 1024 characters so it won't in practice. ------------------------------------------------------------------------------ H : S_Long := 0; I : Natural := Str'First; C : Character; begin ----Do it this way if we are not ignoring case. if not Ignore_Case then loop if I > Str'Last then exit; end if; H := H + Character'Pos (Str (I)); I := I + 1; if I > Str'Last then exit; end if; H := H + Character'Pos (Str (I)) * 2 ** 4; I := I + 1; if I > Str'Last then exit; end if; H := H + Character'Pos (Str (I)) * 2 ** 8; I := I + 1; if I > Str'Last then exit; end if; H := H + Character'Pos (Str (I)) * 2 ** 12; I := I + 1; if I > Str'Last then exit; end if; H := H + Character'Pos (Str (I)) * 2 ** 16; I := I + 1; if I > Str'Last then exit; end if; H := H + Character'Pos (Str (I)) * 2 ** 20; I := I + 1; end loop; ----Do it this way if we are not ignoring case. else loop if I > Str'Last then exit; end if; C := Str (I); if C in 'a' .. 'z' then C := Character'Val (Character'Pos (C) - (Character'Pos ('a') - Character'Pos ('A'))); end if; H := H + Character'Pos (C); I := I + 1; if I > Str'Last then exit; end if; C := Str (I); if C in 'a' .. 'z' then C := Character'Val (Character'Pos (C) - (Character'Pos ('a') - Character'Pos ('A'))); end if; H := H + Character'Pos (C) * 2 ** 4; I := I + 1; if I > Str'Last then exit; end if; C := Str (I); if C in 'a' .. 'z' then C := Character'Val (Character'Pos (C) - (Character'Pos ('a') - Character'Pos ('A'))); end if; H := H + Character'Pos (C) * 2 ** 8; I := I + 1; if I > Str'Last then exit; end if; C := Str (I); if C in 'a' .. 'z' then C := Character'Val (Character'Pos (C) - (Character'Pos ('a') - Character'Pos ('A'))); end if; H := H + Character'Pos (C) * 2 ** 12; I := I + 1; if I > Str'Last then exit; end if; C := Str (I); if C in 'a' .. 'z' then C := Character'Val (Character'Pos (C) - (Character'Pos ('a') - Character'Pos ('A'))); end if; H := H + Character'Pos (C) * 2 ** 16; I := I + 1; if I > Str'Last then exit; end if; C := Str (I); if C in 'a' .. 'z' then C := Character'Val (Character'Pos (C) - (Character'Pos ('a') - Character'Pos ('A'))); end if; H := H + Character'Pos (C) * 2 ** 20; I := I + 1; end loop; end if; return H; end Hash; --\f procedure Read_File (File : Text_Io.File_Type; Line_List : in out File_Line_List; Line_Listi : in out S_Natural; Ignore_Case : Boolean) is ------------------------------------------------------------------------------ -- File - Specifies the file to read. -- Line_List - Receives the list of lines read -- Line_Listi - Receives the number of lines in the list -- Ignore_Case - Specifies TRUE if the hash is to ignore case -- -- Called to read an entire file into memory. ------------------------------------------------------------------------------ Line : String (1 .. 1024); Linei : Natural; Eop : Boolean; Eof : Boolean; begin ----Initialize our output array. Line_List := new File_Line_Array (1 .. 1000); Line_Listi := 0; ----Read the file to the end. loop Read_Line (File, Line, Linei, Eop, Eof); if Eof then return; end if; if Line_Listi = Line_List'Last then declare Newl : File_Line_List := new File_Line_Array (1 .. Line_List'Length * 2); begin Newl (1 .. Line_List'Length) := Line_List.all; Free_File_Line_Array (Line_List); Line_List := Newl; end; end if; Line_Listi := Line_Listi + 1; Line_List (Line_Listi) := new File_Line_Rec'(Line => new String'(Line (1 .. Linei)), Hash => Hash (Line (1 .. Linei), Ignore_Case), Eop => Eop, Blank => Is_Blank (Line (1 .. Linei))); end loop; end Read_File; --\f procedure Regions_Differ (List1 : File_Line_Array; List2 : File_Line_Array) is ------------------------------------------------------------------------------ -- List1 - Specifies the lines in file 1 that don't match -- List2 - Specifies the lines in file 2 that don't match -- -- Called when we (may) have a region of lines in file1 that don't match some -- region of lines in file2. Report them to the log. ------------------------------------------------------------------------------ begin ----If there are no lines from File1 then we either have no difference or else -- we have an Insert. if List1'Length = 0 then if List2'Length = 0 then return; -- Nothing to report. end if; New_Line; Put ("--- Insert "); Put (List1'First); Put (","); Put (S_Long (List2'Length)); New_Line; for I in List2'Range loop Put ("> "); Put_Line (List2 (I).Line.all); end loop; return; end if; ----If there are no lines from File2 then we have a Delete. if List2'Length = 0 then New_Line; Put ("--- Delete "); Put (List1'First); Put (","); Put (S_Long (List1'Length)); New_Line; for I in List1'Range loop Put ("< "); Put_Line (List1 (I).Line.all); end loop; return; end if; ----Otherwise we have a change. New_Line; Put ("--- Change "); Put (List1'First); Put (","); Put (S_Long (List1'Length)); Put (","); Put (S_Long (List2'Length)); New_Line; for I in List1'Range loop Put ("< "); Put_Line (List1 (I).Line.all); end loop; Put_Line ("--- ------"); for I in List2'Range loop Put ("> "); Put_Line (List2 (I).Line.all); end loop; return; end Regions_Differ; --\f procedure Diff_Cb (List1 : File_Line_Array; List2 : File_Line_Array) is ------------------------------------------------------------------------------ -- List1 - Specifies the lines from file 1 -- List2 - Specifies the lines from file 2 -- -- Called to perform the main work of the Files_Diff routine. -- -- Ignore_Case => FALSE -- Ignore_Blank_Lines => FALSE ------------------------------------------------------------------------------ Line1 : File_Line; Line2 : File_Line; Line1i : S_Natural := 0; Line2i : S_Natural := 0; Last_Line1i : S_Natural := 0; Last_Line2i : S_Natural := 0; Tmp1 : S_Natural; Tmp2 : S_Natural; begin ----Check our assumptions. if List1'First /= List2'First then raise Program_Error; -- Our assumption fails. end if; ----Match lines starting at the top until we don't match any more. for I in List1'Range loop if I > List2'Last then exit; end if; Line1 := List1 (I); Line2 := List2 (I); if Line1.Hash /= Line2.Hash or else Line1.Line.all /= Line2.Line.all then exit; end if; Last_Line1i := I; Last_Line2i := I; end loop; ----Loop until we have gone over the entirety of both lists. Main_Diff_Loop: loop ----Loop until we find a non-blank Line1 that has a matching Line2. Line1_Line2_Loop: loop ----Loop until we find the next non-blank Line1 of any flavor. for I in Line1i + 1 .. List1'Last loop if not List1 (I).Blank then Line1 := List1 (I); Line1i := I; goto Have_Line1; end if; end loop; exit Main_Diff_Loop; -- Can't find a next Line1. ----We get here when we have a Line1 and we need to find a matchine Line2. <<Have_Line1>> null; for I in Line2i + 1 .. List2'Last loop Line2 := List2 (I); if not Line2.Blank then if Line1.Hash = Line2.Hash and then Line1.Line.all = Line2.Line.all then Line2i := I; exit Line1_Line2_Loop; end if; end if; end loop; ----If we get here then there is no Line2 that matches Line1. Loop and go -- after the next non-blank Line1. end loop Line1_Line2_Loop; ----Come here when we have Line1 = Line2 and we now want to expand the -- region of match. Loop backwards looking for a line that doesn't match. -- Then report that region of difference. <<Have_A_Match>> null; Tmp1 := Line1i; Tmp2 := Line2i; while Line1i - 1 > Last_Line1i and then Line2i - 1 > Last_Line2i loop Line1 := List1 (Line1i - 1); Line2 := List2 (Line2i - 1); if Line1.Hash /= Line2.Hash or else Line1.Line.all /= Line2.Line.all then exit; end if; Line1i := Line1i - 1; Line2i := Line2i - 1; end loop; Regions_Differ (List1 (Last_Line1i + 1 .. Line1i - 1), List2 (Last_Line2i + 1 .. Line2i - 1)); ----Now loop forwards looking for a line that doesn't match. That defines -- our next starting point. Line1i := Tmp1; Line2i := Tmp2; while Line1i < List1'Last and then Line2i < List2'Last loop Line1 := List1 (Line1i + 1); Line2 := List2 (Line2i + 1); if Line1.Hash /= Line2.Hash or else Line1.Line.all /= Line2.Line.all then exit; end if; Line1i := Line1i + 1; Line2i := Line2i + 1; end loop; Last_Line1i := Line1i; Last_Line2i := Line2i; ----Loop and go after the next matching region. end loop Main_Diff_Loop; ----Come here when we can't find a next-non-blank Line1. Regions_Differ (List1 (Last_Line1i + 1 .. List1'Last), List2 (Last_Line2i + 1 .. List2'Last)); end Diff_Cb; --\f procedure Diff_Ci (List1 : File_Line_Array; List2 : File_Line_Array) is ------------------------------------------------------------------------------ -- List1 - Specifies the lines from file 1 -- List2 - Specifies the lines from file 2 -- -- Called to perform the main work of the Files_Diff routine. -- -- Ignore_Case => FALSE -- Ignore_Blank_Lines => TRUE ------------------------------------------------------------------------------ Line1 : File_Line; Line2 : File_Line; Line1i : S_Natural := 0; Line2i : S_Natural := 0; Last_Line1i : S_Natural := 0; Last_Line2i : S_Natural := 0; Tmp1 : S_Natural; Tmp2 : S_Natural; begin ----Check our assumptions. if List1'First /= List2'First then raise Program_Error; -- Our assumption fails. end if; ----Match lines starting at the top until we don't match any more. Pre_Diff_Loop: loop loop if Last_Line1i = List1'Last then exit Pre_Diff_Loop; elsif not List1 (Last_Line1i + 1).Blank then exit; end if; Last_Line1i := Last_Line1i + 1; end loop; Line1 := List1 (Last_Line1i + 1); loop if Last_Line2i = List1'Last then exit Pre_Diff_Loop; elsif not List1 (Last_Line2i + 1).Blank then exit; end if; Last_Line2i := Last_Line2i + 1; end loop; Line2 := List1 (Last_Line2i + 1); if Line1.Hash /= Line2.Hash or else Line1.Line.all /= Line2.Line.all then exit; end if; Last_Line1i := Last_Line1i + 1; Last_Line2i := Last_Line2i + 1; end loop Pre_Diff_Loop; ----Loop until we have gone over the entirety of both lists. Main_Diff_Loop: loop ----Loop until we find a non-blank Line1 that has a matching Line2. Line1_Line2_Loop: loop ----Loop until we find the next non-blank Line1 of any flavor. for I in Line1i + 1 .. List1'Last loop if not List1 (I).Blank then Line1 := List1 (I); Line1i := I; goto Have_Line1; end if; end loop; exit Main_Diff_Loop; -- Can't find a next Line1. ----We get here when we have a Line1 and we need to find a matchine Line2. <<Have_Line1>> null; for I in Line2i + 1 .. List2'Last loop Line2 := List2 (I); if not Line2.Blank then if Line1.Hash = Line2.Hash and then Line1.Line.all = Line2.Line.all then Line2i := I; exit Line1_Line2_Loop; end if; end if; end loop; ----If we get here then there is no Line2 that matches Line1. Loop and go -- after the next non-blank Line1. end loop Line1_Line2_Loop; ----Come here when we have Line1 = Line2 and we now want to expand the -- region of match. Loop backwards looking for a line that doesn't match. -- Then report that region of difference. <<Have_A_Match>> null; Tmp1 := Line1i; Tmp2 := Line2i; ----Skip backwards from the match looking for lines that aren't blank and which -- don't match. Post_Diff_Loop1: loop loop if Line1i - 1 <= Last_Line1i then exit Post_Diff_Loop1; end if; Line1 := List1 (Line1i - 1); if not Line1.Blank then exit; end if; Line1i := Line1i - 1; end loop; loop if Line2i - 1 <= Last_Line2i then exit Post_Diff_Loop1; end if; Line2 := List2 (Line2i - 1); if not Line2.Blank then exit; end if; Line2i := Line2i - 1; end loop; if Line1.Hash /= Line2.Hash or else Line1.Line.all /= Line2.Line.all then exit Post_Diff_Loop1; end if; Line1i := Line1i - 1; Line2i := Line2i - 1; end loop Post_Diff_Loop1; ----Skip blanks at the start of the difference regions. while Last_Line1i + 1 < Line1i - 1 loop if not List1 (Last_Line1i + 1).Blank then exit; end if; Last_Line1i := Last_Line1i + 1; end loop; while Last_Line2i + 1 < Line2i - 1 loop if not List1 (Last_Line2i + 1).Blank then exit; end if; Last_Line2i := Last_Line2i + 1; end loop; Regions_Differ (List1 (Last_Line1i + 1 .. Line1i - 1), List2 (Last_Line2i + 1 .. Line2i - 1)); ----Now loop forwards looking for a line that doesn't match. That defines -- our next starting point. Line1i := Tmp1; Line2i := Tmp2; Post_Diff_Loop2: loop loop if Line1i >= List1'Last then exit Post_Diff_Loop2; end if; Line1 := List1 (Line1i + 1); if not Line1.Blank then exit; end if; Line1i := Line1i + 1; end loop; loop if Line2i >= List2'Last then exit Post_Diff_Loop2; end if; Line2 := List2 (Line2i + 1); if not Line2.Blank then exit; end if; Line2i := Line2i + 1; end loop; if Line1.Hash /= Line2.Hash or else Line1.Line.all /= Line2.Line.all then exit Post_Diff_Loop2; end if; Line1i := Line1i + 1; Line2i := Line2i + 1; end loop Post_Diff_Loop2; Last_Line1i := Line1i; Last_Line2i := Line2i; ----Loop and go after the next matching region. end loop Main_Diff_Loop; ----Come here when we can't find a next-non-blank Line1. while Last_Line1i + 1 < List1'Last loop if not List1 (Last_Line1i + 1).Blank then exit; end if; Last_Line1i := Last_Line1i + 1; end loop; while Last_Line2i + 1 < List2'Last loop if not List1 (Last_Line2i + 1).Blank then exit; end if; Last_Line2i := Last_Line2i + 1; end loop; Regions_Differ (List1 (Last_Line1i + 1 .. List1'Last), List2 (Last_Line2i + 1 .. List2'Last)); end Diff_Ci; --\f procedure Diff_Ib (List1 : File_Line_Array; List2 : File_Line_Array) is ------------------------------------------------------------------------------ -- List1 - Specifies the lines from file 1 -- List2 - Specifies the lines from file 2 -- -- Called to perform the main work of the Files_Diff routine. -- -- Ignore_Case => TRUE -- Ignore_Blank_Lines => FALSE ------------------------------------------------------------------------------ Line1 : File_Line; Line2 : File_Line; Line1i : S_Natural := 0; Line2i : S_Natural := 0; Last_Line1i : S_Natural := 0; Last_Line2i : S_Natural := 0; Tmp1 : S_Natural; Tmp2 : S_Natural; begin ----Check our assumptions. if List1'First /= List2'First then raise Program_Error; -- Our assumption fails. end if; ----Match lines starting at the top until we don't match any more. for I in List1'Range loop if I > List2'Last then exit; end if; Line1 := List1 (I); Line2 := List2 (I); if Line1.Hash /= Line2.Hash or else not Equal_Uc (Line1.Line.all, Line2.Line.all) then exit; end if; Last_Line1i := I; Last_Line2i := I; end loop; ----Loop until we have gone over the entirety of both lists. Main_Diff_Loop: loop ----Loop until we find a non-blank Line1 that has a matching Line2. Line1_Line2_Loop: loop ----Loop until we find the next non-blank Line1 of any flavor. for I in Line1i + 1 .. List1'Last loop if not List1 (I).Blank then Line1 := List1 (I); Line1i := I; goto Have_Line1; end if; end loop; exit Main_Diff_Loop; -- Can't find a next Line1. ----We get here when we have a Line1 and we need to find a matchine Line2. <<Have_Line1>> null; for I in Line2i + 1 .. List2'Last loop Line2 := List2 (I); if not Line2.Blank then if Line1.Hash = Line2.Hash and then Equal_Uc (Line1.Line.all, Line2.Line.all) then Line2i := I; exit Line1_Line2_Loop; end if; end if; end loop; ----If we get here then there is no Line2 that matches Line1. Loop and go -- after the next non-blank Line1. end loop Line1_Line2_Loop; ----Come here when we have Line1 = Line2 and we now want to expand the -- region of match. Loop backwards looking for a line that doesn't match. -- Then report that region of difference. <<Have_A_Match>> null; Tmp1 := Line1i; Tmp2 := Line2i; while Line1i - 1 > Last_Line1i and then Line2i - 1 > Last_Line2i loop Line1 := List1 (Line1i - 1); Line2 := List2 (Line2i - 1); if Line1.Hash /= Line2.Hash or else not Equal_Uc (Line1.Line.all, Line2.Line.all) then exit; end if; Line1i := Line1i - 1; Line2i := Line2i - 1; end loop; Regions_Differ (List1 (Last_Line1i + 1 .. Line1i - 1), List2 (Last_Line2i + 1 .. Line2i - 1)); ----Now loop forwards looking for a line that doesn't match. That defines -- our next starting point. Line1i := Tmp1; Line2i := Tmp2; while Line1i < List1'Last and then Line2i < List2'Last loop Line1 := List1 (Line1i + 1); Line2 := List2 (Line2i + 1); if Line1.Hash /= Line2.Hash or else not Equal_Uc (Line1.Line.all, Line2.Line.all) then exit; end if; Line1i := Line1i + 1; Line2i := Line2i + 1; end loop; Last_Line1i := Line1i; Last_Line2i := Line2i; ----Loop and go after the next matching region. end loop Main_Diff_Loop; ----Come here when we can't find a next-non-blank Line1. Regions_Differ (List1 (Last_Line1i + 1 .. List1'Last), List2 (Last_Line2i + 1 .. List2'Last)); end Diff_Ib; --\f procedure Diff_Ii (List1 : File_Line_Array; List2 : File_Line_Array) is ------------------------------------------------------------------------------ -- List1 - Specifies the lines from file 1 -- List2 - Specifies the lines from file 2 -- -- Called to perform the main work of the Files_Diff routine. -- -- Ignore_Case => TRUE -- Ignore_Blank_Lines => TRUE ------------------------------------------------------------------------------ Line1 : File_Line; Line2 : File_Line; Line1i : S_Natural := 0; Line2i : S_Natural := 0; Last_Line1i : S_Natural := 0; Last_Line2i : S_Natural := 0; Tmp1 : S_Natural; Tmp2 : S_Natural; begin ----Check our assumptions. if List1'First /= List2'First then raise Program_Error; -- Our assumption fails. end if; ----Match lines starting at the top until we don't match any more. Pre_Diff_Loop: loop loop if Last_Line1i = List1'Last then exit Pre_Diff_Loop; elsif not List1 (Last_Line1i + 1).Blank then exit; end if; Last_Line1i := Last_Line1i + 1; end loop; Line1 := List1 (Last_Line1i + 1); loop if Last_Line2i = List1'Last then exit Pre_Diff_Loop; elsif not List1 (Last_Line2i + 1).Blank then exit; end if; Last_Line2i := Last_Line2i + 1; end loop; Line2 := List1 (Last_Line2i + 1); if Line1.Hash /= Line2.Hash or else not Equal_Uc (Line1.Line.all, Line2.Line.all) then exit; end if; Last_Line1i := Last_Line1i + 1; Last_Line2i := Last_Line2i + 1; end loop Pre_Diff_Loop; ----Loop until we have gone over the entirety of both lists. Main_Diff_Loop: loop ----Loop until we find a non-blank Line1 that has a matching Line2. Line1_Line2_Loop: loop ----Loop until we find the next non-blank Line1 of any flavor. for I in Line1i + 1 .. List1'Last loop if not List1 (I).Blank then Line1 := List1 (I); Line1i := I; goto Have_Line1; end if; end loop; exit Main_Diff_Loop; -- Can't find a next Line1. ----We get here when we have a Line1 and we need to find a matchine Line2. <<Have_Line1>> null; for I in Line2i + 1 .. List2'Last loop Line2 := List2 (I); if not Line2.Blank then if Line1.Hash = Line2.Hash and then Equal_Uc (Line1.Line.all, Line2.Line.all) then Line2i := I; exit Line1_Line2_Loop; end if; end if; end loop; ----If we get here then there is no Line2 that matches Line1. Loop and go -- after the next non-blank Line1. end loop Line1_Line2_Loop; ----Come here when we have Line1 = Line2 and we now want to expand the -- region of match. Loop backwards looking for a line that doesn't match. -- Then report that region of difference. <<Have_A_Match>> null; Tmp1 := Line1i; Tmp2 := Line2i; ----Skip backwards from the match looking for lines that aren't blank and which -- don't match. Post_Diff_Loop1: loop loop if Line1i - 1 <= Last_Line1i then exit Post_Diff_Loop1; end if; Line1 := List1 (Line1i - 1); if not Line1.Blank then exit; end if; Line1i := Line1i - 1; end loop; loop if Line2i - 1 <= Last_Line2i then exit Post_Diff_Loop1; end if; Line2 := List2 (Line2i - 1); if not Line2.Blank then exit; end if; Line2i := Line2i - 1; end loop; if Line1.Hash /= Line2.Hash or else not Equal_Uc (Line1.Line.all, Line2.Line.all) then exit Post_Diff_Loop1; end if; Line1i := Line1i - 1; Line2i := Line2i - 1; end loop Post_Diff_Loop1; ----Skip blanks at the start of the difference regions. while Last_Line1i + 1 < Line1i - 1 loop if not List1 (Last_Line1i + 1).Blank then exit; end if; Last_Line1i := Last_Line1i + 1; end loop; while Last_Line2i + 1 < Line2i - 1 loop if not List1 (Last_Line2i + 1).Blank then exit; end if; Last_Line2i := Last_Line2i + 1; end loop; Regions_Differ (List1 (Last_Line1i + 1 .. Line1i - 1), List2 (Last_Line2i + 1 .. Line2i - 1)); ----Now loop forwards looking for a line that doesn't match. That defines -- our next starting point. Line1i := Tmp1; Line2i := Tmp2; Post_Diff_Loop2: loop loop if Line1i >= List1'Last then exit Post_Diff_Loop2; end if; Line1 := List1 (Line1i + 1); if not Line1.Blank then exit; end if; Line1i := Line1i + 1; end loop; loop if Line2i >= List2'Last then exit Post_Diff_Loop2; end if; Line2 := List2 (Line2i + 1); if not Line2.Blank then exit; end if; Line2i := Line2i + 1; end loop; if Line1.Hash /= Line2.Hash or else not Equal_Uc (Line1.Line.all, Line2.Line.all) then exit Post_Diff_Loop2; end if; Line1i := Line1i + 1; Line2i := Line2i + 1; end loop Post_Diff_Loop2; Last_Line1i := Line1i; Last_Line2i := Line2i; ----Loop and go after the next matching region. end loop Main_Diff_Loop; ----Come here when we can't find a next-non-blank Line1. while Last_Line1i + 1 < List1'Last loop if not List1 (Last_Line1i + 1).Blank then exit; end if; Last_Line1i := Last_Line1i + 1; end loop; while Last_Line2i + 1 < List2'Last loop if not List1 (Last_Line2i + 1).Blank then exit; end if; Last_Line2i := Last_Line2i + 1; end loop; Regions_Differ (List1 (Last_Line1i + 1 .. List1'Last), List2 (Last_Line2i + 1 .. List2'Last)); end Diff_Ii; --\f procedure Files_Diff (File1 : String; File2 : String; Ignore_Case : Boolean; Ignore_Blank_Lines : Boolean) is ------------------------------------------------------------------------------ -- File1 - Specifies the name of the first file -- File2 - Specifies the name of the second file -- Ignore_Case - Specifies TRUE if 'a' = 'A' -- Ignore_Blank_Lines - Specifies TRUE if blanks lines "don't exist" -- -- We do a simple minded "diff" of two files and send the output to the log. -- We don't expect to handle megabytes of stuff so don't be surprised if we -- blow up on very large files. We bring the entirity of both files into -- memory. ------------------------------------------------------------------------------ F1 : Text_Io.File_Type; F2 : Text_Io.File_Type; List1 : File_Line_List; List2 : File_Line_List; List1i : S_Natural; List2i : S_Natural; begin ----Open the files for reading. Put_Line ("::: diff( " & File1 & ", " & File2 & " );"); begin Text_Io.Open (F1, Text_Io.In_File, File1); exception when others => Put_Error ("Could not open file to compare [" & File1 & "}."); return; end; begin Text_Io.Open (F2, Text_Io.In_File, File2); exception when others => Put_Error ("Could not open file to compare [" & File2 & "}."); Text_Io.Close (F1); return; end; ----Read in the files. Read_File (F1, List1, List1i, Ignore_Case); Read_File (F2, List2, List2i, Ignore_Case); ----Close the files. Text_Io.Close (F1); Text_Io.Close (F2); ----Diff the files. if Ignore_Case then if Ignore_Blank_Lines then Diff_Ii (List1 (1 .. List1i), List2 (1 .. List2i)); else Diff_Ib (List1 (1 .. List1i), List2 (1 .. List2i)); end if; else if Ignore_Blank_Lines then Diff_Ci (List1 (1 .. List1i), List2 (1 .. List2i)); else Diff_Cb (List1 (1 .. List1i), List2 (1 .. List2i)); end if; end if; ----Free our storage and return. Free_File_Line_List (List1); Free_File_Line_List (List2); exception when others => Free_File_Line_List (List1); Free_File_Line_List (List2); Put_Line ("%%% Unexpected exception in Text_Io.Files_Diff?"); Text_Io.Close (F1); Text_Io.Close (F2); return; end Files_Diff; --\f function Change_Wildcards (Wild_In : String) return String is ------------------------------------------------------------------------------ -- Wild_In - Specifies a wildcard file name in R1000 format -- -- Returns the local equivalent to the R1000 wildcarded string. ------------------------------------------------------------------------------ --/ if Unix then --// --// Wild_Out : String (1 .. Wild_In'Length * 3); --// Wild_Outi : Natural := 0; --// Wild_Ini : Natural := Wild_In'First; --// --/ end if; begin --/ if R1000 then return Wild_In; --/ elsif Unix then --// --// while Wild_Ini <= Wild_In'Last loop --// if Wild_In (Wild_Ini) = '^' then --// Wild_Ini := Wild_Ini + 1; --// if Wild_Ini > Wild_In'Last then --// Wild_Out (Wild_Outi + 1 .. Wild_Outi + 2) := ".."; --// Wild_Outi := Wild_Outi + 2; --// else --// if Wild_In (Wild_Ini) = '.' then --// Wild_Ini := Wild_Ini + 1; --// end if; --// Wild_Out (Wild_Outi + 1 .. Wild_Outi + 3) := "../"; --// Wild_Outi := Wild_Outi + 3; --// end if; --// elsif Wild_In (Wild_Ini) = '$' then --// Wild_Ini := Wild_Ini + 1; --// if Wild_Ini > Wild_In'Last then --// Wild_Outi := Wild_Outi + 1; --// Wild_Out (Wild_Outi .. Wild_Outi) := "."; --// else --// if Wild_In (Wild_Ini) = '.' then --// Wild_Ini := Wild_Ini + 1; --// end if; --// Wild_Out (Wild_Outi + 1 .. Wild_Outi + 2) := "./"; --// Wild_Outi := Wild_Outi + 2; --// end if; --// elsif Wild_In (Wild_Ini) = '.' then --// Wild_Ini := Wild_Ini + 1; --// Wild_Outi := Wild_Outi + 1; --// Wild_Out (Wild_Outi) := '/'; --// elsif Wild_In (Wild_Ini) = '@' then --// Wild_Ini := Wild_Ini + 1; --// Wild_Outi := Wild_Outi + 1; --// Wild_Out (Wild_Outi) := '*'; --// else --// Wild_Outi := Wild_Outi + 1; --// Wild_Out (Wild_Outi) := Wild_In (Wild_Ini); --// end if; --// end loop; --// return Wild_Out (1 .. Wild_Outi); --// --/ else --// --// Need_Something_Here; --// --/ end if; end Change_Wildcards; --\f procedure Resolve_Wildcards (Names : String; Extra : String) is ------------------------------------------------------------------------------ -- Names - Specifies the name with wildcards -- Extra - Specifies extra stuff to go onto the end of the Name string -- -- Called to find all of the files referenced by the Name string. -- We process the Name string. It is expected to be in R1000 wildcard -- notation ($/^/./@ only are allowed). We change it to be suitable for -- the current system and then we append the Extra to it. -- Usage: -- Resolve_Wildcards( "@", ".exe" ); -- while not Wild_Done loop -- do_something( Wild_Current ); -- Wild_Next; -- end loop; ------------------------------------------------------------------------------ --/ if R1000 then Wild_Iter : Directory_Tools.Object.Iterator; Name : File_Name; Last : File_Name; Str : String_Pointer; --/ elsif Unix then --// --// File : Text_Io.File_Type; --// Line : String (1 .. 1024); --// Linei : Natural; --// Name : File_Name; --// Last : File_Name; --// Str : String_Pointer; --// --/ end if; begin --/ if R1000 then ----Resolve the wildcards and check for errors. Wild_Iter := Directory_Tools.Naming.Resolution (Names & Extra); if Directory_Tools.Object.Is_Bad (Wild_Iter) then Put_Error ("Could not locate wildcards [" & Names & Extra & "]."); Put_Error ("Error: " & Directory_Tools.Object.Message (Wild_Iter)); raise Test_Io_Error; end if; ----Put all of the names onto our list. Name_List := null; Last := null; while not Directory_Tools.Object.Done (Wild_Iter) loop Str := new String'(Directory_Tools.Naming.Full_Name (Directory_Tools.Object.Value (Wild_Iter))); Name := new File_Name_Rec'(Next => null, Name => Str); if Last /= null then Last.Next := Name; end if; Last := Name; if Name_List = null then Name_List := Name; end if; Directory_Tools.Object.Next (Wild_Iter); end loop; --/ elsif TeleGen2 and then Unix then --// --// ----Resolve the wildcards and check for errors. --// --// if System_Calls.System ("/bin/ls -l " & --// Change_Wildcards (Names) & Extra & --// " > ./_Wild_Test_Io") < 0 then --// Put_Error ("Could not execute ls to resolve wildcards?"); --// Put_Error (Error_Messages.Sys_Error_Message (Error_Messages.Errno)); --// raise Test_Io_Error; --// end if; --// --// ----Put all of the names onto our list. --// --// Text_Io.Open (File, Text_Io.In_File, "./_Wild_Test_Io"); --// Text_Io.Get_Line (File, Line, Linei); --// Name_List := null; --// Last := null; --// while not Text_Io.End_Of_File (File) loop --// Text_Io.Get_Line (File, Line, Linei); --// for I in reverse 1 .. Linei loop --// if Line (I) /= ' ' then --// Linei := I; --// exit; --// end if; --// end loop; --// for I in reverse 1 .. Linei loop --// if Line (I) = ' ' then --// Str := new String'(Line (I + 1 .. Linei)); --// exit; --// end if; --// end loop; --// Name := new File_Name_Rec' (Next => null, --// Name => Str); --// if Last /= null then --// Last.Next := Name; --// end if; --// Last := Name; --// if Name_List = null then --// Name_List := Name; --// end if; --// end loop; --// Text_Io.Close (File); --// --/ else --// --// Need_Something_Here; --// --/ end if; end Resolve_Wildcards; --\f procedure Wild_Next is ------------------------------------------------------------------------------ -- Called to progress to the next wildcard. ------------------------------------------------------------------------------ Name : File_Name; begin if Name_List = null then raise Test_Io_Error; end if; Name := Name_List; Name_List := Name_List.Next; Free_File_Name (Name); end Wild_Next; --\f function Wild_Current return String is ------------------------------------------------------------------------------ -- Called to obtain the current value of the wildcard. ------------------------------------------------------------------------------ begin if Name_List = null then raise Test_Io_Error; end if; return Name_List.Name.all; end Wild_Current; --\f function Wild_Done return Boolean is ------------------------------------------------------------------------------ -- Called to see if there are more wildcards available. ------------------------------------------------------------------------------ begin return Name_List = null; end Wild_Done; --\f end Test_Io;