Category : Miscellaneous Language Source Code
Archive   : ADAMAKE.ZIP
Filename : TABLE.PKG

pragma PAGE_LENGTH (60);
pragma PAGE;
---------------------------------------------------------------
-- File : TABLE.PKG
-- Date : 07/07/88
-- By : Robert Monroe
--
-- The package body of DOS.DIRECTORY.TABLE
---------------------------------------------------------------
with TEXT_IO, WORD_OPS;

separate (DOS.DIRECTORY)

package body TABLE is

package INT_IO is new TEXT_IO.INTEGER_IO (INTEGER);

procedure FILL_LIST (TBLPTR : in out DirTable) is
-- Recursive routine to load the linked list pointed to
-- by TBLPTR.
-- Allocate a new element in the list and fills it in
-- with the current data in FYEAR, FMONTH, and FDAY.
-- Call FIND_NEXT and then FILL_LIST recursively, until
-- the global flag END_OF_LIST is set true.

begin

if END_OF_LIST then

FREE (TBLPTR);
else
-- Allocate new table entry

TBLPTR.FNEXT := new FILE_TABLETP'

(FNAME => (others => CHARACTER'Val (0)),
FSIZE => 0.0,
FTIME => null,
FNEXT => null);

TBLPTR.FNAME := STR (FINFO.NAME);

TBLPTR.FTIME := new TIME_MARKTP;

declare
T : TimeMark renames TBLPTR.FTIME;
begin

T.PACKED_TIME := FINFO.FILE_TIME;
T.PACKED_DATE := FINFO.FILE_DATE;

end;

-- TBLPTR.FSIZE := FSIZE;

-- Fill in the DTA (FINFO) with the next
-- matching file info.

FIND_NEXT; -- DOS function 4Fh

FILL_LIST (TBLPTR.FNEXT);

end if;

end FILL_LIST;

pragma PAGE;

function LOAD (SPEC : in STRING) return DirTable is
-- Get a table of the directory entries specified
-- by NAME. All DOS wildcard characters are valid.

TEMP : DirTable := null;
begin

-- Call DOS to fetch the file info and put
-- it into the FINFO record.

FIND_MATCH (SPEC); -- DOS function 4Eh

if END_OF_LIST then
return null;
else

-- Allocate the first entry in a new table

TEMP := new FILE_TABLETP'

(FNAME => (others => CHARACTER'Val (0)),
FSIZE => 0.0,
FTIME => null,
FNEXT => null);

-- Fill the table with info on
-- files matching SPEC.

FILL_LIST (TEMP);

end if;

return TEMP;

end LOAD;

pragma PAGE;

function CLEAR (TBLPTR : in DirTable) return DirTable is
-- Deallocate the list pointed to by TBLPTR.

TEMP : DirTable := TBLPTR;
NEXT : DirTable;

begin
if TEMP /= NULL then
NEXT := TEMP.FNEXT;
FREE (TEMP);
TEMP := CLEAR (NEXT);
end if;
return null;
end CLEAR;


function NAME (TBLPTR : in DirTable) return STRING is
-- Return the name field of TBLPTR
begin
if TBLPTR /= null then
return TBLPTR.FNAME;
else
return "";
end if;
end NAME;


function SIZE (TBLPTR : in DirTable) return FLOAT is
-- Return the size field of TBLPTR
begin
if TBLPTR /= null then
return TBLPTR.FSIZE;
else
return 0.0;
end if;
end SIZE;


function TIME (TBLPTR : in DirTable) return TimeMark is
-- Return the time field of TBLPTR
begin
if TBLPTR /= null then
return TBLPTR.FTIME;
else
return null;
end if;
end TIME;


function NEXT (TBLPTR : in DirTable) return DirTable is
-- Return the next entry in the list pointed to by TBLPTR
begin
if TBLPTR /= null and
TBLPTR.FNEXT /= null then
return TBLPTR.FNEXT;
else
return null;
end if;
end NEXT;


function IS_EMPTY (TBLPTR : in DirTable) return BOOLEAN is
-- Return true if TBLPTR is null
begin
return TBLPTR = null;
end IS_EMPTY;


function NEWEST (TBLPTR1,
TBLPTR2 : in DirTable) return DirTable is
-- Return the most recently created/modified of two
-- table entries.
DATE1 : WORD renames TBLPTR1.FTIME.PACKED_DATE;
DATE2 : WORD renames TBLPTR2.FTIME.PACKED_DATE;
TIME1 : WORD renames TBLPTR1.FTIME.PACKED_TIME;
TIME2 : WORD renames TBLPTR2.FTIME.PACKED_TIME;
begin
if WORD_OPS.">" (DATE1, DATE2) then
return TBLPTR1;
elsif WORD_OPS."<" (DATE1, DATE2) then
return TBLPTR2;
-- The date is the same so check the times
elsif WORD_OPS."<" (TIME1, TIME2) then
return TBLPTR2;
else
return TBLPTR1;
end if;
end NEWEST;


procedure PUT_TIME (TBLPTR : in DirTable) is
-- Print the time of creation/modification to Standard Output
-- formatted.
use INT_IO;

T : WORD renames TBLPTR.FTIME.PACKED_TIME;
TEMP : STRING (1..2);
BUFF : STRING (1..8) := " : : ";
I : INTEGER := 1;
RANGE_ERROR : exception;
begin

GET_TIME (T);

if FHOURS > 23 then raise RANGE_ERROR; end if;

PUT (TEMP, FHOURS);
if FHOURS < 10 then TEMP (1) := '0'; end if;
BUFF (1..2) := TEMP (1..2);

PUT (TEMP, FMINUTES);
if FMINUTES < 10 then TEMP (1) := '0'; end if;
BUFF (4..5) := TEMP (1..2);

PUT (TEMP, FSECONDS);
if FSECONDS < 10 then TEMP (1) := '0'; end if;
BUFF (7..8) := TEMP (1..2);

TEXT_IO.PUT (BUFF);

exception
when RANGE_ERROR =>
TEXT_IO.PUT_LINE ("PUT_TIME : " &
"*** Hours out of range ***");

end PUT_TIME;


procedure PUT_DATE (TBLPTR : in DirTable) is
-- Print the date of creation/modification to Standard Output
-- formatted.
use INT_IO;

D : WORD renames TBLPTR.FTIME.PACKED_DATE;
TEMP : STRING (1..2);
BUFF : STRING (1..8) := " - - ";
begin

GET_DATE (D);

PUT (TEMP, FMONTH);
if FMONTH < 10 then TEMP (1) := '0'; end if;
BUFF (1..2) := TEMP (1..2);

PUT (TEMP, FDAY);
if FDAY < 10 then TEMP (1) := '0'; end if;
BUFF (4..5) := TEMP (1..2);

PUT (TEMP, FYEAR-1900);
BUFF (7..8) := TEMP (1..2);

TEXT_IO.PUT (BUFF);

end PUT_DATE;


end TABLE;