Trailing-Edge
-
PDP-10 Archives
-
DEC_CMS-20_V1.0_SRC
-
cms/sources/iolog.bli
There are no other files named iolog.bli in the archive.
MODULE iolog (
IDENT = '1',
%if
%bliss(bliss32)
%then
language(bliss32),
addressing_mode(external=long_relative,
nonexternal=long_relative)
%else
language(bliss36)
%fi
) =
BEGIN
!
! COPYRIGHT (c) 1982 BY
! DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASS.
!
! THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
! ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
! INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
! COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
! OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
! TRANSFERRED.
!
! THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
! AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
! CORPORATION.
!
! DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
! SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL.
!
!++
! FACILITY: CMS Library processor
!
! ABSTRACT:
!
! This module handles all IO to the Project log.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
!
! AUTHOR: R. Wheater CREATION DATE: 13-May-80
!
! MODIFIED BY:
!
!--
!
! TABLE OF CONTENTS:
!
FORWARD ROUTINE
bldcom, ! builds log format from command to remark
get_mem:novalue, ! gets more memory for the character string
logtrn ; ! main routine for writing log record
!
! INCLUDE FILES:
!
%if
%bliss(bliss32)
%then
library 'sys$library:starlet';
%else
%if %switches(tops20) %then
require 'JSYS:' ;
%else
%error('DS-10 SUPPORT NOT IMPLEMENTED')
%FI
%fi
library 'XPORT:';
require 'BLISSX:';
require 'COMUSR:';
require 'HOSUSR:';
require 'LOGUSR:';
require 'SCONFG:';
require 'SHRUSR:';
!
! MACROS:
!
!
! EQUATED SYMBOLS:
!
!
! OWN STORAGE:
!
own
cmd_code, ! command code
$io_block(llog), ! iob for history (log) file
l_rem: initial(0), ! work length
p_tmp: initial(k_null) ; ! work pointer
!
! EXTERNAL REFERENCES:
!
external routine
badxpo, ! print xport error(TERMIO)
bug, ! print bug message(TERMIO)
codspl, ! get spelling(SPELLS)
curcom, ! get parse command(COMAND)
getact, ! get user id(GETACT)
getac2, ! fake it on the -20
logtim, ! get date,time (TRANSA)
trnfil ; ! register for recovery(TRANSA)
GLOBAL ROUTINE logtrn(option,l_gen,p_gen) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will take a generation string as input and write
! a record to the project log. The record may be marked as unusual
! depending on the option used.
!
! FORMAL PARAMETERS:
!
! option specifies whether or not to mark the record as
! unusual. The values are:
!
! k_normal_log
! k_unusual_log
!
! l_gen length of generation string
!
! p_gen pointer to generation string
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! k_success = normal completion
! k_silent_error = error in processing
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
literal
max_date = 9, ! max length of date string
max_time = 8, ! max length of time string
max_user = 30 ; ! max lenght of user string
own
d_com_rec: ref desc_block, ! portion of record from command
! to remark
d_beg_rec: desc_block, ! first portion of the record
d_ful_rec: ref desc_block ; ! full log record
local
l_lxm, ! length of this lexeme
l_rem, ! work length remaining
p_tmp, ! work pointer
stat; ! xport status returned
! initialize descriptors
$str_desc_init(descriptor=d_beg_rec,string=(0,k_null)) ;
! get memory for beginning portion of record
d_beg_rec[desc_len] = max_date + max_time + max_user + 3 ;
$xpo_get_mem(characters=.d_beg_rec[desc_len],result=d_beg_rec[desc_ptr]);
p_tmp = .d_beg_rec[desc_ptr] ;
l_rem = .d_beg_rec[desc_len] ;
! get date and time and transfer to buffer
l_lxm = logtim(.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.l_lxm) ;
ch$wchar_a(%c' ',p_tmp) ;
l_rem = .l_rem - .l_lxm - 1 ;
! now transfer user string
%if %bliss(bliss36) %then
%if %switches(tops20) %then
l_lxm = getac2(.p_tmp) ;
%else
%error ('DS-10 support not implemented')
%fi
%fi
%if %bliss(bliss32) %then
l_lxm = getact(.p_tmp) ;
%fi
p_tmp = ch$plus(.p_tmp,.l_lxm) ;
ch$wchar_a(%c' ',p_tmp) ;
l_rem = .l_rem - .l_lxm - 1 ;
! adjust descriptor length to exact size
d_beg_rec[desc_len] = .d_beg_rec[desc_len] - .l_rem ;
!build rest of record
if
not bldcom(d_com_rec,.option,.l_gen,.p_gen)
then
bug(cat('Error in reconstructing command. Error occurred in routine ',
'LOGTRN of module IOLOG')) ;
! concatentate two records into one
d_ful_rec = cat(d_beg_rec,.d_com_rec) ;
!+
! record is built, now must add record to history file
!+
! open history file
stat = $step_open(iob=llog_iob,file_spec=(%string(lib,log)),
options=append,failure=0) ;
if
.stat neq step$_normal and
.stat neq step$_created
then
badxpo(.stat,lit('Unable to open history file')) ;
! register file for recovery
trnfil(llog_iob) ;
! write the output file record
$step_put(iob=llog_iob,string=.d_ful_rec) ;
! close history file
stat = $step_close(iob=llog_iob,failure=0) ;
if
.stat neq step$_normal
then
badxpo(.stat,lit('Unable to close history file')) ;
true
END; ! end of routine logtrn
ROUTINE bldcom(a_com_log,option,gen_len,gen_ptr) =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will build the portion of the log record containing
! the command,subcommand,qualifiers,parameters,and remark. The string
! is formed as a concatented string with blank delimiters separating
! the fields.
!
! FORMAL PARAMETERS:
!
! a_com_log address of descriptor returned by this routine of
! the concatentated string.
!
! option type of log record being written. values are:
!
! k_normal_log
! k_unusual_log
!
! gen_len length of generation string (input to this routine).
!
! gen_ptr pointer to generation string (input to this routine).
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! True = successful completion of this routine
! False = processing failure
!
! SIDE EFFECTS:
!
! None
!
!--
BEGIN
own
a_parm_blk: ref parameter_block,
a_qual_blk: ref qualifier_block,
d_cat_rec: desc_block, ! desc of concatented string
d_spel_str: ref desc_block, ! desc of full spelling string
f_1st_parm: initial(true) ; ! indicates that this is 1st parameter
local
sub_code, ! subcommand code
a_qual_1st, ! address of first qualifier block
a_parm_1st, ! address of first parameter block
a_rem_desc: ref desc_block ; ! address of remark desc
! initialize desc and get initial memory
$str_desc_init(descriptor=d_cat_rec,string=(0,k_null)) ;
get_mem(d_cat_rec,l_rem,p_tmp) ;
! get parsed command
curcom(cmd_code,sub_code,a_qual_1st,a_parm_1st,a_rem_desc) ;
! get command code string
if
.cmd_code neq 0
then
begin ! valid command code
d_spel_str = codspl(.cmd_code) ;
if
.l_rem lss (.d_spel_str[desc_len] + 1)
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
! transfer command string + 1 blank
ch$move(.d_spel_str[desc_len],.d_spel_str[desc_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.d_spel_str[desc_len]) ;
ch$wchar_a(%c' ',p_tmp) ;
l_rem = .l_rem - .d_spel_str[desc_len] - 1 ;
end ; ! valid command code
!+
! must now build subcommand field
!+
if
.l_rem lss 1
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
! write starting quote
ch$wchar_a(%c'"',p_tmp) ;
l_rem = .l_rem - 1 ;
if
.sub_code neq 0
then
begin ! valid subcommand code
d_spel_str = codspl(.sub_code) ;
if
.l_rem lss (.d_spel_str[desc_len] + 1)
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
! transfer quote + subcommand
ch$move(.d_spel_str[desc_len],.d_spel_str[desc_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.d_spel_str[desc_len]) ;
l_rem = .l_rem - .d_spel_str[desc_len] ;
end ; ! valid subcommand code
!+
! Now select the command qualifiers
!+
! get start of qualifiers
a_qual_blk = .a_qual_1st ;
until
.a_qual_blk eql k_null
do
begin ! reconstruct qualifiers loop
if
.a_qual_blk[qua_code] neq 0
then
begin ! valid qual
d_spel_str = codspl(.a_qual_blk[qua_code]) ;
if
.l_rem lss .d_spel_str[desc_len]
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
! transfer qualifier
ch$move(.d_spel_str[desc_len],.d_spel_str[desc_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.d_spel_str[desc_len]) ;
l_rem = .l_rem - .d_spel_str[desc_len] ;
! now check for text string present
if
(.a_qual_blk[qua_value_len] gtr 0) and
(.a_qual_blk[qua_value_ptr] neq k_null)
then
begin ! text present
if
.l_rem lss (.a_qual_blk[qua_value_len] + 5)
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'=',p_tmp) ;
if
ch$rchar(.a_qual_blk[qua_value_ptr]) eql %c'"'
then
begin
ch$wchar_a(%c'"',p_tmp) ;
l_rem = .l_rem - 1 ;
end ;
ch$move(.a_qual_blk[qua_value_len],
.a_qual_blk[qua_value_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.a_qual_blk[qua_value_len]) ;
! add quotes
if
ch$rchar(.a_qual_blk[qua_value_ptr]) eql %c'"'
then
begin
ch$wchar_a(%c'"',p_tmp) ;
l_rem = .l_rem - 1 ;
end ;
! calculate remaining length
l_rem = .l_rem - .a_qual_blk[qua_value_len] - 1 ;
end ; ! text present
end ; ! valid qual
a_qual_blk = .a_qual_blk[qua_a_next] ;
end ; ! reconstruct qualifiers loop
! check for unusual
if
.option eql k_unusual_log
then
begin ! build /u for unusual occurance
if
.l_rem lss 2
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'/',p_tmp) ;
ch$wchar_a(%c'U',p_tmp) ;
l_rem = .l_rem - 2 ;
end ; ! build /u for unusual occurance
! add closing quotes and a blank
if
.l_rem lss 2
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'"',p_tmp) ;
ch$wchar_a(%c' ',p_tmp) ;
l_rem = .l_rem - 2 ;
!+
! Now must build the parameter string
!+
! put in starting quote
if
.l_rem lss 1
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'"',p_tmp) ;
l_rem = .l_rem - 1 ;
! point to first parameter
a_parm_blk = .a_parm_1st ;
until
.a_parm_blk eql k_null
do
begin ! loop thru parameters
if
.l_rem lss .a_parm_blk[par_text_len]
then
get_mem(d_cat_rec,l_rem,p_tmp);
ch$move(.a_parm_blk[par_text_len],
.a_parm_blk[par_text_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.a_parm_blk[par_text_len]) ;
l_rem = .l_rem - .a_parm_blk[par_text_len] ;
! now build /gen if generation string provided
if
((.gen_len gtr 0) and
(.gen_ptr neq k_null)) and .f_1st_parm
then
begin ! generation given
if
.l_rem lss (.gen_len + 1)
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'/',p_tmp) ;
ch$move(.gen_len,.gen_ptr,.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.gen_len) ;
l_rem = .l_rem - .gen_len - 1 ;
f_1st_parm = false ;
end ; ! generation given
! check for parameter qualifiers
if
.a_parm_blk[par_a_qual] neq k_null
then
begin ! add parameter qualifiers
a_qual_blk = .a_parm_blk[par_a_qual] ;
until
.a_qual_blk eql k_null
do
begin ! reconstruct qualifiers loop
if
.a_qual_blk[qua_code] neq 0
then
begin ! valid qual
d_spel_str = codspl(.a_qual_blk[qua_code]) ;
if
.l_rem lss .d_spel_str[desc_len]
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
! transfer qualifier
ch$move(.d_spel_str[desc_len],.d_spel_str[desc_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.d_spel_str[desc_len]) ;
l_rem = .l_rem - .d_spel_str[desc_len] ;
! now check for text string present
if
(.a_qual_blk[qua_value_len] gtr 0) and
(.a_qual_blk[qua_value_ptr] neq k_null)
then
begin ! text present
if
.l_rem lss (.a_qual_blk[qua_value_len] + 5)
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'=',p_tmp) ;
if
ch$rchar(.a_qual_blk[qua_value_ptr]) eql %c'"'
then
begin
ch$wchar_a(%c'"',p_tmp) ;
l_rem = .l_rem - 1 ;
end ;
ch$move(.a_qual_blk[qua_value_len],
.a_qual_blk[qua_value_ptr],.p_tmp) ;
p_tmp = ch$plus(.p_tmp,.a_qual_blk[qua_value_len]) ;
! add quotes
if
ch$rchar(.a_qual_blk[qua_value_ptr]) eql %c'"'
then
begin
ch$wchar_a(%c'"',p_tmp) ;
l_rem = .l_rem - 1 ;
end ;
! calculate remaining length
l_rem = .l_rem - .a_qual_blk[qua_value_len] - 1 ;
end ; ! text present
end ; ! valid qual
a_qual_blk = .a_qual_blk[qua_a_next] ;
end ; ! reconstruct qualifiers loop
end ; ! add parameter qualifiers
! if more than one parameter exists, insert blank
if
.a_parm_blk[par_a_next] neq k_null
then
begin ! add blank
if
.l_rem lss 1
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c' ',p_tmp) ;
l_rem = .l_rem - 1 ;
end ; ! add blank
! advance to next block
a_parm_blk = .a_parm_blk[par_a_next] ;
end ; ! loop thru parameters
! put on closing quote and space
if
.l_rem lss 2
then
get_mem(d_cat_rec,l_rem,p_tmp) ;
ch$wchar_a(%c'"',p_tmp) ;
ch$wchar_a(%c' ',p_tmp) ;
l_rem = .l_rem - 2 ;
! adjust desc
d_cat_rec[desc_len] = .d_cat_rec[desc_len] - .l_rem ;
!+
! now add remark descriptor to string
!+
if
.cmd_code eql k_verify_com
then
!no remark set in verify
.a_com_log=cat(d_cat_rec,'""')
else
.a_com_log = cat(d_cat_rec,.a_rem_desc) ;
! normal return
true
END; ! end of routine bldcom
ROUTINE get_mem(a_desc,a_wk_rem,a_wk_ptr):novalue =
!++
! FUNCTIONAL DESCRIPTION:
!
! This routine will get more memory for a character string. The
! old character string is copied into the new string memory area
! and the working pointers and lengths updated. The old string
! memory area is subsequently freed. On the initial call the
! routine allocates memory when indicated by null input descriptor.
!
! FORMAL PARAMETERS:
!
! a_desc address of descriptor of memory for character string.
!
! a_wk_rem address of length remaining
!
! a_wk_ptr address of working pointer
!
! IMPLICIT INPUTS:
!
! None.
!
! IMPLICIT OUTPUTS:
!
! None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
! None.
!
! SIDE EFFECTS:
!
! None.
!
!--
BEGIN
literal
exp_fac = 120 ; ! expansion factor for number of
! addition memory character needed
bind
d_str= .a_desc: desc_block, ! desc of memory area
w_rem = .a_wk_rem, ! remaining length
w_ptr = .a_wk_ptr ; ! working pointer
local
p_new_blk, ! pointer to new block
l_used_old, ! length of old block used
new_len ; ! length after expansion
if
(.d_str[desc_ptr] eql k_null)
then
begin ! initial allocation
$xpo_get_mem(characters=exp_fac,
result=d_str[desc_ptr]) ;
d_str[desc_len] = exp_fac ;
! set work pointer + length
w_rem = .d_str[desc_len] ;
w_ptr = .d_str[desc_ptr] ;
return
end; ! initial allocation
if
(.d_str[desc_ptr] neq k_null)
then
begin ! string expansion required
! compute used portion of old string
l_used_old = .d_str[desc_len] - .w_rem ;
new_len = .d_str[desc_len] + exp_fac ;
$xpo_get_mem(characters=.new_len,result=p_new_blk) ;
! transfer characters to new block and free old
ch$move(.l_used_old,.d_str[desc_ptr],.p_new_blk) ;
$xpo_free_mem(string=(.d_str[desc_len],.d_str[desc_ptr])) ;
! update desc and working pointer and length
d_str[desc_len] = .new_len ;
d_str[desc_ptr] = .p_new_blk ;
w_rem = .d_str[desc_len] - .l_used_old ;
w_ptr = ch$plus(.d_str[desc_ptr],.l_used_old) ;
end ; ! string expansion required
END; ! end of routine get_mem
END ! End of module
ELUDOM