%TITLE 'SHELF_IO'
MODULE shelf_io(IDENT = 'V1.0',
ADDRESSING_MODE(EXTERNAL=LONG_RELATIVE, NONEXTERNAL=LONG_RELATIVE)) =
BEGIN
!++
! FACILITY: MGBOOK
!
! MODULE DESCRIPTION:
!
! This module contains routines to read and write .DECW$BOOKSHELF files.
!
! AUTHOR: Darrell Burkhead
! Copyright © 1995, MadGoat Software.
! ALL RIGHTS RESERVED.
!
! CREATION DATE: December 6, 1994
!
! MODIFICATION HISTORY:
!
! V1.0 Darrell Burkhead 6-DEC-1994 15:34
! Original version.
!--
LIBRARY 'SYS$LIBRARY:STARLET';
LIBRARY 'MGBOOK';
LIBRARY 'FIELDS';
FORWARD ROUTINE
open_shelf_file,
close_shelf_file : NOVALUE,
read_shelf_file,
write_shelf_file;
BIND
title_ad = %ASCID'TITLE',
shelf_ad = %ASCID'SHELF',
book_ad = %ASCID'BOOK';
LITERAL
max_shelf_line = 255;
_DEF(sfctx)
sfctx_l_flags = _LONG,
_OVERLAY(sfctx_l_flags)
sfctx_v_write = _BIT,
_ENDOVERLAY
sfctx_t_fab = _BYTES(FAB$C_BLN),
sfctx_t_rab = _BYTES(RAB$C_BLN),
sfctx_t_nam = _BYTES(NAM$C_BLN),
sfctx_t_esbuf = _BYTES(NAM$C_MAXRSS),
_ALIGN(LONG)
sfctx_t_rsbuf = _BYTES(NAM$C_MAXRSS),
_ALIGN(LONG)
sfctx_t_buffer = _BYTES(max_shelf_line)
_ENDDEF(sfctx);
%SBTTL 'OPEN_SHELF_FILE'
GLOBAL ROUTINE open_shelf_file(filename_a, context_a_a, defname_a, resfile_a,
open_mode) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine opens a shelf file for the specified access.
!
! RETURNS: cond_value, longword(unsigned), write only, by value
!
! IMPLICIT INPUTS:
!
! IMPLICIT OUTPUTS:
!
! COMPLETION CODES:
!
! SS$_NORMAL: normal successful completion.
!
! SIDE EFFECTS:
!
! None.
!--
BIND
filename = .filename_a : $BBLOCK,
context = .context_a_a : REF SFCTXDEF,
defname = .defname_a : $BBLOCK,
resfile = .resfile_a : $BBLOCK;
BUILTIN
NULLPARAMETER;
LOCAL
temp_dna : INITIAL(0),
temp_dns : INITIAL(0),
mode : INITIAL(IF NULLPARAMETER(open_mode)
THEN shelf_read ELSE .open_mode),
err_filebuf : $BBLOCK[NAM$C_MAXRSS],
err_filedsc : $BBLOCK[DSC$C_S_BLN] PRESET(
[DSC$B_CLASS] = DSC$K_CLASS_S,
[DSC$B_DTYPE] = DSC$K_DTYPE_T,
[DSC$A_POINTER] = err_filebuf),
out_addr : REF $BBLOCK,
out_len : WORD,
status,
statusv : INITIAL(0);
EXTERNAL ROUTINE
g_hat(LIB$GET_VM, STR$ANALYZE_SDESC, STR$COPY_R);
!
! Set up the filename to be used in case of an error.
!
STR$ANALYZE_SDESC(filename, out_len, out_addr);
CH$MOVE(.out_len, .out_addr, !Copy the filename
err_filebuf);
err_filedsc[DSC$W_LENGTH] = .out_len; !Save the length
status = LIB$GET_VM(%REF(SFCTX_S_SFCTXDEF), context);
IF .status
THEN BEGIN
BIND
fab = context[SFCTX_T_FAB] : $BBLOCK,
rab = context[SFCTX_T_RAB] : $BBLOCK,
nam = context[SFCTX_T_NAM] : $BBLOCK;
context[SFCTX_L_FLAGS] = 0;
context[SFCTX_V_WRITE] = .mode EQL shelf_write OR
.mode EQL shelf_append;
IF NOT NULLPARAMETER(defname_a)
THEN BEGIN
temp_dna = .defname[DSC$A_POINTER]; !Save the default name info
temp_dns = .defname[DSC$W_LENGTH];
END; !End of default name provided
$FAB_INIT( !Initialize the FAB
FAB = fab,
FNS = .filename[DSC$W_LENGTH],
FNA = .filename[DSC$A_POINTER],
DNS = .temp_dns,
DNA = .temp_dna,
NAM = nam);
$NAM_INIT( !Initialize the NAM
NAM = nam,
ESA = context[SFCTX_T_ESBUF],
ESS = NAM$C_MAXRSS,
RSA = context[SFCTX_T_RSBUF],
RSS = NAM$C_MAXRSS);
IF .mode EQL shelf_read
THEN BEGIN
fab[FAB$B_FAC] = FAB$M_GET; !Open for reading
fab[FAB$B_SHR] = FAB$M_SHRGET;
status = $OPEN(FAB = fab); !Open the shelf file
IF .status EQL RMS$_FNF
THEN BEGIN
EXTERNAL shelf_dnm : $BBLOCK;
fab[FAB$L_DNA] = .shelf_dnm[DSC$A_POINTER];
fab[FAB$B_DNS] = .shelf_dnm[DSC$W_LENGTH];
status = $OPEN(FAB = fab); !Try again w/a new default
END; !End of switch defaults
END !End of open for reading
ELSE BEGIN
fab[FAB$B_FAC] = FAB$M_PUT; !Open for writing
fab[FAB$V_CR] = 1; !Carriage-return record attr.
fab[FAB$V_MXV] = 1; !Maximize version #
IF .mode EQL shelf_append
THEN fab[FAB$V_CIF] = 1; !Create if it doesn't exist
status = $CREATE(FAB = fab) !Create (or open) the shelf file
END; !End of open for writing
IF NOT .status
THEN statusv = .fab[FAB$L_STV]
ELSE BEGIN
CH$MOVE(.nam[NAM$B_RSL], !Copy the filename
.nam[NAM$L_RSA], err_filebuf);
err_filedsc[DSC$W_LENGTH] = .nam[NAM$B_RSL];
$RAB_INIT( !Initialize the RAB
RAB = rab,
FAB = fab);
IF .mode EQL shelf_append
THEN rab[RAB$V_EOF] = 1; !Position at EOF
IF .context[SFCTX_V_WRITE]
THEN rab[RAB$L_RBF] = context[SFCTX_T_BUFFER]
ELSE BEGIN
rab[RAB$L_UBF] = context[SFCTX_T_BUFFER];
rab[RAB$W_USZ] = max_shelf_line;
END; !End of set up for reading
status = $CONNECT(RAB = rab);
IF NOT .status
THEN statusv = .rab[RAB$L_STV]
ELSE IF NOT NULLPARAMETER(resfile_a)
THEN status = STR$COPY_R(resfile, !Save the resultant filename
%REF(.nam[NAM$B_NODE]+.nam[NAM$B_DEV]+
.nam[NAM$B_DIR]+.nam[NAM$B_NAME]),
context[SFCTX_T_RSBUF]);
END; !End of opened shelf file
IF NOT .status
THEN close_shelf_file(context); !Error, clean up
END; !End of context allocated
IF NOT .status
THEN SIGNAL(MGBOOK__OPENIN, 1, err_filedsc, .status, .statusv);
.status OR STS$M_INHIB_MSG
END; !End of open_shelf_file
%SBTTL 'CLOSE_SHELF_FILE'
GLOBAL ROUTINE close_shelf_file(context_a_a) : NOVALUE =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine closes the shelf file specified.
!
! RETURNS: None.
!
! IMPLICIT INPUTS:
!
! IMPLICIT OUTPUTS:
!
! SIDE EFFECTS:
!
! None.
!--
BIND
context = .context_a_a : REF SFCTXDEF,
fab = context[SFCTX_T_FAB] : $BBLOCK;
EXTERNAL ROUTINE
g_hat(LIB$FREE_VM);
IF .fab[FAB$W_IFI] NEQ 0
THEN $CLOSE(FAB = fab);
LIB$FREE_VM(%REF(SFCTX_S_SFCTXDEF), context);
END; !End of close_shelf_file
%SBTTL 'READ_SHELF_FILE'
GLOBAL ROUTINE read_shelf_file(context_a_a, type_a, title_a, filename_a) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine reads a line from the specfied shelf file.
!
! RETURNS: cond_value, longword(unsigned), write only, by value
!
! IMPLICIT INPUTS:
!
! IMPLICIT OUTPUTS:
!
! COMPLETION CODES:
!
! SS$_NORMAL: normal successful completion.
!
! SIDE EFFECTS:
!
! None.
!--
BIND
context = .context_a_a : REF SFCTXDEF,
type = .type_a : LONG,
title = .title_a : $BBLOCK,
filename = .filename_a : $BBLOCK,
rab = context[SFCTX_T_RAB] : $BBLOCK,
delim = %ASCID'\';
LOCAL
status,
statusv : INITIAL(0);
EXTERNAL ROUTINE
g_hat(STR$ELEMENT, STR$CASE_BLIND_COMPARE, STR$FREE1_DX);
status =
(IF .context[SFCTX_V_WRITE]
THEN MGBOOK__SHELFACC
ELSE SS$_NORMAL);
WHILE .status
DO BEGIN
status = $GET(RAB = rab);
IF .status
THEN BEGIN
BIND first_char = .rab[RAB$L_RBF] : BYTE;
IF NOT (.rab[RAB$W_RSZ] GEQ 1 AND
(.first_char EQL %C'!' OR .first_char EQL %C'#')) AND
(.rab [RAB$W_RSZ] NEQ 0)
THEN EXITLOOP; !Skip comment and blank lines
END !End of check for comment
ELSE statusv = .rab[RAB$L_STV];
END;
IF .status
THEN BEGIN
LOCAL
line : $BBLOCK[DSC$C_S_BLN] PRESET(
[DSC$W_LENGTH] = .rab[RAB$W_RSZ],
[DSC$B_CLASS] = DSC$K_CLASS_S,
[DSC$B_DTYPE] = DSC$K_DTYPE_T,
[DSC$A_POINTER] = .rab[RAB$L_RBF]),
type_str : $BBLOCK[DSC$C_S_BLN];
$INIT_DYNDESC(type_str);
status = STR$ELEMENT(type_str, %REF(0), delim, line);
IF .status
THEN BEGIN
IF STR$CASE_BLIND_COMPARE(type_str, title_ad) EQL 0
THEN type = sfile_title
ELSE IF STR$CASE_BLIND_COMPARE(type_str, shelf_ad) EQL 0
THEN type = sfile_shelf
ELSE IF STR$CASE_BLIND_COMPARE(type_str, book_ad) EQL 0
THEN type = sfile_book
ELSE status = MGBOOK__UNKTYPE;
IF .status
THEN status = STR$ELEMENT(filename, %REF(1), delim, line);
IF .status
THEN status = STR$ELEMENT(title, %REF(2), delim, line);
STR$FREE1_DX(type_str); !Clean up
END; !End of got the type
IF NOT .status
THEN SIGNAL(MGBOOK__BADENTRY, 1, line, .status);
END !End of read a line
ELSE IF .status NEQ RMS$_EOF
THEN BEGIN
SIGNAL(MGBOOK__READERR, 0, .status, .statusv);
status = .status OR STS$M_INHIB_MSG;
END; !Not EOF, need to signal
.status
END; !End of read_shelf_file
%SBTTL 'WRITE_SHELF_FILE'
GLOBAL ROUTINE write_shelf_file(context_a_a, type, title_a, filename_a) =
BEGIN
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine writes a line to the specified shelf file.
!
! RETURNS: cond_value, longword(unsigned), write only, by value
!
! IMPLICIT INPUTS:
!
! IMPLICIT OUTPUTS:
!
! COMPLETION CODES:
!
! SS$_NORMAL: normal successful completion.
!
! SIDE EFFECTS:
!
! None.
!--
BIND
context = .context_a_a : REF SFCTXDEF,
title = .title_a : $BBLOCK,
filename = .filename_a : $BBLOCK,
rab = context[SFCTX_T_RAB] : $BBLOCK;
LOCAL
out_desc : $BBLOCK[DSC$C_S_BLN] PRESET(
[DSC$W_LENGTH] = max_shelf_line,
[DSC$B_CLASS] = DSC$K_CLASS_S,
[DSC$B_DTYPE] = DSC$K_DTYPE_T,
[DSC$A_POINTER] = context[SFCTX_T_BUFFER]),
status,
statusv : INITIAL(0);
status =
(IF NOT .context[SFCTX_V_WRITE]
THEN MGBOOK__SHELFACC
ELSE SS$_NORMAL);
IF .status
THEN status = $FAO(%ASCID'!AS\!AS\!AS', !Format the output line
rab[RAB$W_RSZ], out_desc,
(IF .type EQL sfile_title
THEN title_ad
ELSE IF .type EQL sfile_shelf
THEN shelf_ad
ELSE book_ad),
filename, title);
IF .status
THEN BEGIN
status = $PUT(RAB = rab); !Write the output line
IF NOT .status
THEN statusv = .rab[RAB$L_STV]; !Save secondary status
END; !End of output line formatted
IF NOT .status
THEN SIGNAL(MGBOOK__WRITEERR, 0, .status, .statusv);
.status OR STS$M_INHIB_MSG
END; !End of write_shelf_file
END
ELUDOM