HP 3000 Manuals HP 3000 Manuals
Program Example A-2
This Pascal/XL program example illustrates how you can use the HPFOPEN
intrinsic to open a labeled magnetic tape file, then open a new disk file
with a user-supplied name. After records are sequentially copied from
the tape file to the disk file, both files are closed, the disk file is
closed as a Permanent file. If the file system determines that another
file of the same name exists in the permanent file directory, the user is
allowed to specify alternate file names until the file close operation is
successful.
Program Algorithm
The task specified above is accomplished using six steps. 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) labeled magnetic tape file (see procedure
open_tape_file).
2. Read from $STDIN (READ) a user-supplied file name, then open
(HPFOPEN) a new disk file using the given name (see procedure
open_disk_file).
3. Read (FREADLABEL) the user label from the tape file and then print
(PRINT) the label to $STDLIST (see procedure print_user_label).
4. In a loop, use sequential access method to read (FREAD) records
from tape file and write (FWRITE) them to the disk file (see
procedure copy_file_from_tape_to_disc).
5. Close (FCLOSE) the tape file (see procedure close_tape_file).
6. Close (FCLOSE) the new disk file as a permanent file (see
procedure close_disk_file). If an error occurs during the FCLOSE
call, the user is given the opportunity (CAUSEBREAK) to
interactively fix the problem (see procedure handle_fclose_error)
before the program again attempts to close the disk file as a
permanent file.
This program makes extensive use of error handling routines to:
* return to the user a file system error number (FCHECK) associated
with a file system intrinsic error (refer to procedure
print_fserr).
* interpret and return to the user error information returned by the
status parameter of a failed HPFOPEN call (see procedure
print_hpfopen_error).
* allow the user to specify an alternative file name if, during an
FCLOSE call, the file system determines that a duplicate permanent
disk file exists (see procedure handle_fclose_error).
* print file information (PRINTFILEINFO) before aborting (QUIT) the
program (see procedure handle_file_error).
Using these four error procedures, the program individually tailors
error-handling routines to meet different intrinsic needs.
Source code listing
Example A-2. Accessing a Magnetic Tape File
$standard_level 'os_features'$
$os 'mpe xl'$
$code_offsets on$
$tables on$
$list_code on$
program open_and_read_a_labeled_tape (input, output);
{************************************************************************}
{* DECLARATION PART *}
{************************************************************************}
const
ccg = 0; {* condition code "greater than *}
ccl = 1; {* condition code "less than" *}
cce = 2; {* condition code "equal" *}
type
pac80 = packed array [1..80] of char;
status_type = record
case integer of
0 : (info : shortint;
subsys : shortint);
1 : (all : integer);
end;
var
tape_file : integer; {* file number for tape file *}
disk_file : integer; {* file number for disk file *}
function FREAD : shortint; intrinsic;
function READ : shortint; intrinsic;
procedure HPFOPEN; intrinsic;
procedure FCHECK; intrinsic;
procedure FCLOSE; intrinsic;
procedure FWRITE; intrinsic;
procedure PRINT; intrinsic;
procedure PRINTFILEINFO; intrinsic;
procedure QUIT; intrinsic;
procedure CAUSEBREAK; intrinsic;
procedure FREADLABEL; intrinsic;
procedure print_hpfopen_error
(
error : status_type
)
option inline;
{************************************************************************}
{* PURPOSE: *}
{* This routine prints the status returned by HPFOPEN. *}
{* PARAMETERS: *}
{* error (input) *}
{* - status returned by HPFOPEN *}
{************************************************************************}
begin {* print_hpfopen_error *}
writeln ('HPFOPEN status = (info: ', error.info:1,
'; subys: ', error.subsys:1,')');
end; {* print_hpfopen_error *}
procedure print_fserr
(
file_num : integer
)
option inline;
{************************************************************************}
{* PURPOSE: *}
{* This routine prints a File System error which occurred in a *}
{* File System intrinsic. *}
{* PARAMETERS: *}
{* file_num (input) *}
{* - file number of file which the intrinsic failed *}
{************************************************************************}
var
error : shortint; {* File System error number *}
begin {* print_fserr *}
FCHECK (file_num, error); {* call FCHECK to get the errornumber*}
writeln ('FSERR = ', error:1);
end;
{* print_fserr *}
procedure handle_file_error
(
file_num : shortint;
quit_num : shortint
);
{************************************************************************}
{* PURPOSE: *}
{* This routine displays File System information about a file *}
{* and then calls QUIT to terminate the program. *}
{* PARAMETERS: *}
{* file_num (input) *}
{* - file number. The routine will print info about this *}
{* file. *}
{* quit_num (input) *}
{* - quit number. This number will be displayed by QUIT when *}
{* the program is terminated. *}
{************************************************************************}
begin {* handle_file_error *}
PRINTFILEINFO (file_num);
QUIT (quit_num);
end; {* handle_file_error *}
procedure handle_fclose_error;
{************************************************************************}
{* PURPOSE: *}
{* This routine informs the user that the disk file could not *}
{* closed. Then CAUSEBREAK is called to break the program; *}
{* this is done to give the user a chance to purge or rename *}
{* an existing disk file which has the same name as the one the *}
{* program is trying to save. When the user enters 'resume' *}
{* this routine will return to the caller. *}
{************************************************************************}
var
msgbuf : pac80;
begin {* handle_fclose_error *}
{* print error messages *}
{************************}
msgbuf := 'Can''t close disk file';
PRINT (msgbuf, -21, 0);
msgbuf := 'Check for duplicate name';
PRINT (msgbuf, -24, 0);
msgbuf := 'Fix, then type "resume"';
PRINT (msgbuf, -23, 0);
{* break the program *}
{*********************}
CAUSEBREAK;
end; {* handle_fclose_error *}
procedure open_tape_file
(
var file_num : integer
);
{************************************************************************}
{* PURPOSE: *}
{* This routine opens a labeled tape file. *}
{* PARAMETERS: *}
{* file_num (output) *}
{* - file number of open tape file *}
{************************************************************************}
const
{* define HPFOPEN item numbers *}
formal_designator_option = 2;
domain_option = 3;
tape_label_option = 8;
access_type_option = 11;
tape_type_option = 30;
tape_expiration_option = 31;
device_class_option = 42;
var
{* define HPFOPEN items *}
read_only : integer;
device_class : pac80;
old : integer;
file_name : pac80;
tape_label : pac80;
ansi_tape : integer;
tape_expiration : pac80;
{* define scratch varibles *}
msgbuf : pac80;
status : status_type;
begin {* open_tape_file *}
{* set up the item values for the HPFOPEN intrinsic *}
{****************************************************}
file_name := '&tapefile&';
old := 3;
read_only := 0;
tape_label := '&tape01&';
ansi_tape := 0;
tape_expiration := '&05/20/87&';
device_class := '&tape&';
HPFOPEN (file_num, status, formal_designator_option, file_name,
device_class_option, device_class,
domain_option, old,
tape_label_option, tape_label,
tape_type_option, ansi_tape,
access_type_option, read_only,
tape_expiration_option, tape_expiration);
if status.all <> 0 then {* check for error condition *}
begin
print_hpfopen_error (status);
handle_file_error (file_num, 1);
end;
end; {* open_tape_file *}
procedure open_disk_file
(
var file_num : integer
);
{************************************************************************}
{* PURPOSE: *}
{* This routine prompts the user for a file name and opens a *}
{* NEW disk file using the given name. *}
{* PARAMETERS: *}
{* file_num (output) *}
{* - file number of the open disk file *}
{************************************************************************}
const
{* define HPFOPEN item numbers *}
formal_designator_option = 2;
access_type_option = 11;
ascii_binary_option = 53;
var
{* define HPFOPEN items *}
update : integer;
ascii : integer;
file_name : pac80;
{* define scratch variables *}
index : integer;
msgbuf : pac80;
read_length : integer;
status : status_type;
begin {* open_disk_file *}
{* prompt user for a file name a read the user-specified name *}
{***************************************************************}
msgbuf := 'Name of new disk file to be created?';
PRINT (msgbuf, -36, 0);
read_length := READ (file_name, -8);
{* shift file name one character to the right to make room for the *}
{* delimiters *}
{************************************************************************}
for index := read_length downto 1 do
file_name[index + 1] := file_name[index];
{* add delimiters to file name *}
{*******************************}
file_name[1] := '&';
file_name[read_length + 2] := '&';
{* set up the remaining item values for the HPFOPEN intrinsic *}
{**************************************************************}
ascii := 1; {* the disk file is to be an ASCII file *}
update := 5; {* update access will be used to write to the disk file*}
HPFOPEN (file_num, status, formal_designator_option, file_name,
ascii_binary_option, ascii,
access_type_option, update);
if status.all <> 0 then {* check for error condition *}
begin
print_hpfopen_error (status);
handle_file_error (file_num, 2);
end;
end; {* open_disk_file * }
procedure print_user_label
(
file_num : integer
);
{************************************************************************}
{* PURPOSE: *}
{* This routine reads the user label from the tape file and *}
{* then prints the user label to $STDLIST. *}
{* PARAMETERS: *}
{* file_num (input) *}
{* - file number of open tape file *}
{************************************************************************}
var
inbuf : pac80; {* buffer for the user label *}
begin {* print_user_label *}
FREADLABEL (file_num, inbuf, 40); {* read the user label from tape*}
if ccode <> CCE then {* check for error condition *}
begin
print_fserr (file_num);
handle_file_error (file_num, 3);
end;
PRINT (inbuf, 40, 0); {* print the user label to $stdlist *}
end; {* print_user_label *}
procedure copy_file_from_tape_to_disk
(
tape_file : integer;
disk_file : integer
);
{************************************************************************}
{* PURPOSE: *}
{* This routine copies a tape file to a disk file one record at *}
{* a time (sequential access). *}
{* PARAMETERS: *}
{* tape_file (input) *}
{* - file number of an open tape file *}
{* disk_file (input) *}
{* - file number of an open disk file *}
{************************************************************************}
var
inbuf : pac80;
msgbuf : pac80;
end_of_file : boolean;
read_length : integer;
begin {* copy_file_from_tape_to_disk *}
end_of_file := false;
repeat
{* copy a buffer from the tape file to the disk file until the *}
{* end of the tape file is reached *}
{*********************************************************************}
read_length := FREAD (tape_file, inbuf, 40);
{* read buffer from tape *}
if ccode = ccl then {* check for error condition *}
begin
msgbuf := 'Can''t read tape file';
PRINT (msgbuf, -20, 0);
print_fserr (tape_file);
handle_file_error (tape_file, 4);
end
else
if ccode = ccg then {* check for end of file condition *}
end_of_file := true
else
begin
FWRITE (disk_file, inbuf, read_length, 0);
{* write buffer to disk *}
if ccode <> cce then {* check for error condition *}
begin
msgbuf := 'Can''t write to disk file';
PRINT (msgbuf, -24, 0);
print_fserr (disk_file);
handle_file_error (disk_file, 5);
end;
end;
until end_of_file;
end; {* copy_file_from_tape_to_disk *}
procedure close_tape_file
(
file_num : integer
);
{************************************************************************}
{* PURPOSE: *}
{* This routine closes the tape file. *}
{* PARAMETERS: *}
{* file_num (input) *}
{* - file number of open tape file *}
{************************************************************************}
var
msgbuf : pac80;
begin {* close_tape_file *}
FCLOSE (file_num, 1, 0); {* close file, rewind and unload tape*}
if ccode = ccl then {* check for error condition *}
begin
msgbuf := 'Can''t close tape file';
PRINT (msgbuf, -21, 0);
print_fserr (file_num);
handle_file_error (file_num, 6);
end;
end; { close_tape_file }
procedure close_disk_file
(
file_num : integer
);
{************************************************************************}
{* PURPOSE: }
{* This routine closes the NEW disk file as PERMANENT disk }
{* file. If an error occurs on the FCLOSE then the user is }
{* given the opportunity to fix the problem and the FCLOSE is }
{* retried. }
{* PARAMETERS: }
{* file_num (input) }
{* - file number of the open disk file }
{************************************************************************}
var
file_closed : boolean;
begin { close_disk_file }
file_closed := false;
repeat
FCLOSE (file_num, 1, 0); { close disk file as a permanent file}
if ccode = ccl then { check for error condition}
handle_fclose_error
else
file_closed := true;
until file_closed;
end; { close_disk_file }
{************************************************************************}
{ MAIN PROGRAM }
{************************************************************************}
begin
open_tape_file (tape_file); { STEP 1 }
open_disk_file (disk_file); { STEP 2 }
print_user_label (tape_file); { STEP 3 }
copy_file_from_tape_to_disk (tape_file, disk_file); { STEP 4 }
close_tape_file (tape_file); { STEP 5 }
close_disk_file (disk_file); { STEP 6 }
end. { main }