|
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 - metrics - 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;