HP 3000 Manuals HP 3000 Manuals
Program Example A-3
This HP Pascal/XL program illustrates how you can use a sequential method
of reading records from an old disk file and use a random access method
of writing the records in an inverted order to a new user-labeled disk
file, where record 1 of the first file is written to location n of the
second file, record 2 is written to location n-1, and so on.
Program Algorithm
The task specified above is accomplished by following the steps described
below. Also indicated are the intrinsics used to accomplish file access
tasks and the name of the procedure where the task is accomplished:
1. Open (HPFOPEN) a permanent disk file and a new user-labeled disk
file (see procedure open_disk_file).
2. Write (FWRITELABEL) a user-defined label to the new file (see
procedure write_user_label).
3. Get EOF (FGETINFO) of old file and assign that value to new file's
record pointer; in a loop, sequentially read (FREAD) records from
old file and write (FWRITEDIR) them to a location in the new file
specified by the record pointer, then decrement the new file's
record pointer (see procedure copy_oldfile_to_newfile). Continue
the loop till the old file's EOF is reached.
4. Close (FCLOSE) the old file as deleted from the system, and close
the new file as a temporary file (see procedure close_disk_file).
If a file system intrinsic returns an unsuccessful condition code,
procedure handle_file_error is called to print file information
(PRINTFILEINFO) and then abort (QUIT) the program.
Source code listing
Example A-3. Random Access
$standard_level 'hp3000'$
$lines 100$
$code_offsets on$
$tables on$
$list_code on$
program write_read (input,output);
{***********************************************************************}
{ DECLARATION PART }
{***********************************************************************}
const
ccg = 0; { condition code warning/EOF,/etc.. }
ccl = 1; { condition code error }
cce = 2; { condition code successful }
permanent = 1;
new = 0;
temp = 2;
delete = 4;
type
pac256 = packed array [1..256] of char;
pac80 = packed array [1..80] of char;
{HPFOPEN status parameter type }
status_type = record
case integer of
0 : (info : shortint;
subsys : shortint);
1 : (all : integer);
end;
var
old_file : integer;
new_file : integer;
filename : pac80;
label_id : integer;
label_len : integer;
outbuf : pac80;
function FREAD: shortint; intrinsic; { sequential read old file }
procedure HPFOPEN; intrinsic; { open both disk files }
procedure FCLOSE; intrinsic; { close both disk files }
procedure FWRITEDIR; intrinsic; { random access write to new file }
procedure FWRITELABEL; intrinsic; { write new user-defined label }
procedure PRINTFILEINFO; intrinsic; { user in error-handler }
procedure FGETINFO; intrinsic; { get EOF location }
procedure QUIT; intrinsic; { use in error-handler }
procedure handle_file_error
(
file_num : shortint;
quit_num : shortint
);
{***********************************************************************}
{ procedure handle_file_error prints file information on the job/session}
{ list device, then aborts the program. }
{***********************************************************************}
begin
PRINTFILEINFO (file_num);
QUIT (quit_num);
end; { end handle_file_error }
procedure open_disk_file
(
var file_num : integer;
file_name : pac80;
domain : integer
);
{***********************************************************************}
{procedure open_disk_file is a generic file open procedure that allows }
{you to specify the file name, it's domain, type of access, and internal}
{format - ASCII or binary. }
{***********************************************************************}
const
{**define HPFOPEN item numbers** }
formal_designator_option = 2;
domain_option = 3;
access_type_option = 11;
ascii_binary_option = 53;
var
{**define HPFOPEN items********* }
update : integer;
ascii : integer;
{**define scratch variables** }
msgbuf : pac80;
status : status_type;
begin
update := 5;
ascii := 1;
HPFOPEN (file_num, status, formal_designator_option, file_name,
domain_option, domain,
ascii_binary_option, ascii,
access_type_option, update);
if status.all <> 0 then
handle_file_error (file_num, 1);
end; { end open_disk_file }
procedure write_user_label
(
file_num : integer;
buffer : pac80;
length : integer;
lnum : integer
);
{************************************************************************}
{ procedure write_user_label writes a user-defined label to the specified}
{ file. }
{************************************************************************}
begin
FWRITELABEL (file_num, buffer, length, lnum);
if ccode <> cce then
handle_file_error (file_num, 2);
end; { end write_user_label }
procedure copy_oldfile_to_newfile
(
new_discfile : integer;
old_discfile : integer
);
{************************************************************************}
{ procedure copy_oldfile_to_newfile gets EOF of old file & assigns record}
{ pointer to that value. In a loop, sequentially reads from old file; }
{ random access writes to new file. }
{************************************************************************}
var
rec : integer;
inbuf : pac256;
end_of_file : boolean;
read_length : integer;
begin
{**Locate the EOF in old disk file** }
end_of_file := false; { initialize loop control variable }
rec := 0;
FGETINFO (old_discfile,,,,,,,,,, rec);
if ccode = ccl then
handle_file_error (old_discfile, 3);
repeat
{**Copy the records in the reverse orders from old disk file**}
{**to the new disk file** }
read_length := FREAD (old_discfile, inbuf, 128);
if ccode = ccl then
handle_file_error (old_discfile, 4)
else
if ccode = ccg then
end_of_file := true
else
begin
rec := rec - 1; { decrement record pointer }
FWRITEDIR (new_discfile, inbuf, 128, rec);
if ccode <> cce then
handle_file_error (new_discfile, 5);
end
until end_of_file { check control variable EOF }
end; { end copy_oldfile_to_newfile }
procedure close_disk_file
(
file_num : integer;
disp : integer
);
{************************************************************************}
{ procedure close_disk_file is a disk file closing procedure that allowsa }
{ you to specify the final disposition of the file you are closing. }
{************************************************************************}
var
msgbuf : pac80;
begin
FCLOSE (file_num, disp, 0);
if ccode = ccl then
handle_file_error (file_num, 6);
end; { end close_disk_file }
{************************************************************************}
{ Main Program }
{************************************************************************}
begin
filename := '&dataone&';
open_disk_file (old_file, filename, permanent); { STEP 1 }
filename := '&datatwo&';
open_disk_file (new_file, filename, new); { STEP 1 }
outbuf := 'Employee Data File';
label_len := 9;
label_id := 0;
write_user_label(new_file, outbuf, label_len, label_id); { STEP 2 }
copy_oldfile_to_newfile(new_file, old_file); { STEP 3 }
close_disk_file(new_file, temp); { STEP 4 }
close_disk_file (old_file, delete); { STEP 4 }
end.