Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

module fixup (! Fix the ills of a library.
		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 contains the routines for doing the VERIFY/REPAIR
!	basic functions
!
! Environment:	VAX/VMS
!
! Author:  Dave Knight
!
!--

!
! Table of Contents:
!

forward routine
	fixcrc,				!Fix a file CRC
	fixhdr;				!Fix up the file header

!
! 
!

%if %bliss(bliss32) %then
library 'SYS$LIBRARY:STARLET' ;
%else
require 'tendef:';
undeclare 
    %quote $chlfd,		! name conflicts between monsym and tendef
    %quote $chcrt;		!   monsym required in jsys:
require 'jsys:';
%fi

library 'XPORT:' ;

require 'BLISSX:' ;

require 'SCONFG:' ;

require 'HOSUSR:' ;

require 'timusr:' ;

require 'filusr:';

require 'rbusr:';

!
! Macros:
!

%if Tops20 %then
macro
    at_eof (jfn) =
	begin
	local status;
	gtsts ((jfn); status);
	.pointr (status,gs_eof)
	end %;
%fi

!
! Equated Symbols:
!
literal
    debug = false;

!
! Own Storage:
!

global
    have_repaired;

global literal
    k_expand_file_size = extended_file_spec + 5,
    k_size_stack  = 40;
!
! External References:
!
external literal
    s_inoopen,			!can not open input file 
    s_onoopen,			!can not open output file
    s_oanoopen,			!can not open output file for append
    s_nosetrev,			!cannot set revision mark for filespec
    s_repairfai,		!cannot repair file
    s_timenoset;		!cannot set the time for filespec

external routine
    bug : novalue,		! Report a bug.
    bugsts : novalue,		! Report a bug involving a status code.
    crccalc,			! Calculate the CRC of a line
    crctable : novalue,		! Set up polynomial table
%if %bliss(bliss36) %then
    cvtas0,			! Convert desc to ASCIZ
    freas0,			! Return dynamic memory allocated by cvtas0
    jfn_truncate,		! truncate a file (filops) /TBD/
%fi
    dirspc : novalue,		! Find the directory portion of a file spec.
    errsts,			! Report an error involving a status code.
    erssts,			! Report an error involving a status code.
    fresad : novalue,		! Free string allocated by ASK or CAT macro.
    hexasz,
    say,
    timcop,
    trnfil,
    truncate : novalue;		! truncate a file

global routine fixcrc (a_file_name, crc, a_custom_msg ) =

!++
! Functional Description:
!
!	This routine will calculate the summed CRC's of a file
! 	and write out the result at the end of the file. The 
! 	control line looks like   */C: .
!
!	TOPS-20: It is assumed that the file is not sequenced and is 
!	composed of 7 bit ASCII characters.  This is true even if XPORT
!	has marked the file as containing 36 bit bytes.
!
! Formal Parameters:
!
!	a_file_name : address of a descriptor of the file 
! 		      to be fixed
!	crc : new count to be written at end of the file
!	a_custom_msg : k_null or the address of a descriptor for a
!			custom message to be printed after successful
!			operation.
!
! Implicit Inputs:
!
!	The file is closed.
!
! Implicit Outputs:
!
!	None.
!
! Routine Value:
! Completion Codes:
!
!	TRUE - File CRC corrected
!	FALSE - CRC fixup failed
!
! Side Effects:
!
!	None.
!
!--

    begin

    bind
	file_name    = .a_file_name  : desc_block,
	d_custom_msg = .a_custom_msg : desc_block;

    literal
	max_byte_count = 256;

    own
	$io_block(rd),
	$io_block(wrt);

    local
	f_cksum,				!flag to show chksum record fnd
	len,
	num_buf : vector[ch$allocation(max_num_size+5)],   ! Space for new crc
	ptr ,
%if VaxVms %then

	save_rfa: vector[rab$s_rfa, byte],	! save area for RFA of record
	save_rab: ref $rab_decl,		! save area for RAB
%fi
%if Tops20 %then

        fbsiz,					! for 20, file byte size
	file_z_ptr,				! temp pointer to ASCIZ string
	skips,					! number skips taken by jsys
	jfn,					! system dependent file handle
	byte_size,				! number of bits per byte (or character) for accessing file
	err_code,				! TOPS-20 error mnemonic from jsys
	upd_count,				! updated count returned by jsys, decremented from original value
	upd_ptr,				! updated byte-ptr into string
	buf : vector[ch$allocation(max_byte_count)],

%fi

	status ;



    have_repaired = true;		! set flag that this routine has
					!  been entered

    f_cksum = false;			!flag clear when no cksum rec 
					! encountered

    ! Make sure filename isn't too long
    if .file_name[desc_len] gtr k_expand_file_size
    then
	bug(cat( file_name, 'is too long for stack (FIXCRC).')) ;

    ! Open the file

%if Tops20 %then

    ! prepair for gtjfn call, convert to ASCIZ
    cvtas0 (file_name, file_z_ptr);

    ! get JFN for specified file
    skips = gtjfn (gj_sht or gj_old, .file_z_ptr; jfn);

    ! release dynamic memory allocated by cvtas0
    freas0 (.file_z_ptr);

    ! do error checking
    if .skips eql 0
    then
	begin
	erssts(s_inoopen, .jfn,
	       cat('Cannot open input file ',file_name, ' (FIXCRC)') );
	return false;
	end;

    byte_size = 7;

    skips = openf (.jfn,		! open file for READ
		   fld(.byte_size,of_bsz) or fld(true,of_rd) or fld(true,of_wr);
		   err_code);

    ! do error checking
    if .skips eql 0
    then
	begin
	erssts(s_inoopen, .err_code,
	       cat('Cannot open input file ',file_name, ' (FIXCRC)') );
	return false;
	end;

    !+
    !  Read every record in the file until you get the end of the file
    !  or until you get to a record containing the checksum data.
    !-

    repeat
	begin

	ptr = ch$ptr (buf);

	%if debug %then				! debug code
	! print out current position in file
	skips = rfptr (.jfn; err_code, fbsiz);

	$xpo_put_msg (string = $str_concat ('FIXCRC: file-pointer = ',
					    $str_ascii(.fbsiz) ));
	%fi					! end debug code

	skips = sin (.jfn,			! job-file-number
		     .ptr,			! input-buffer pointer
		     +max_byte_count,		! read n bytes or until NUL
		     10;			! termination byte = <LF>
		     err_code,			! return error code
		     upd_ptr,			! updated version of 2nd param 
		     upd_count);		! updated count

	if .skips eql 0				! check for error during SIN
	then
	    begin
	    if at_eof (.jfn)			!  must do special processing for EOF check
	    then
		exitloop;

	    bugsts(.err_code,
		   lit('Unable to do GET operation (FIXCRC)') );
	    end;

	%if debug %then
	begin
	local length;
	length = ch$diff(.upd_ptr,.ptr);
	$xpo_put_msg (severity = success,
		      string = $str_concat ('Length = ', $str_ascii(.length),
					    ' Text = "', (.length,.ptr), '"'));
	end;
	%fi

	! I do not understand why, but SIN is not deleting nulls, i.e. it
	! is passing them on as data.  NOTE that it is also passing the
	! CRLF along as data but this is supposd to happen.

	! bypass all nulls in buffer
	while ch$rchar(.ptr) eql 0 
	do
	    ch$rchar_a(ptr);

	if ch$eql( 4, ch$ptr(uplit('*/C:')), 4, .ptr)
	then
	    begin
	    f_cksum = true;
	    exitloop ;	 
	    end;	    

	end ;	!(of REPEAT loop)

    !+
    ! Test to see if checksum was encountered.  If so, that checksum
    ! record must be truncated from the file.
    !-
    if .f_cksum
    then
	begin	! checksum found in file

	! get position in file
	skips = rfptr (.jfn; err_code, fbsiz);

	if .skips eql 0
	then
	    bugsts(.err_code,
		   lit('Unable to get file-pointer from RFPTR jsys (FIXCRC)'));

	! adjust fbsiz to reflect previous record
	fbsiz = .fbsiz - (max_byte_count-.upd_count);

	%if debug %then				! debug code

	! print adjusted file position before doing truncate
	$xpo_put_msg (string = $str_concat ('FIXCRC: adjusted file-pointer = ',
					    $str_ascii(.fbsiz) ));

	%fi					! end debug code

	if not jfn_truncate (.jfn, .byte_size, .fbsiz)
	then
	    begin
	    geter ($fhslf, err_code);
	    bugsts (.err_code,
		    cat('Unable to truncate ', file_name, ' (FIXCRC)'));
	    end;

	end;

    skips = closf (.jfn; err_code);
    if .skips eql 0
    then
	bugsts (.err_code,
		cat('Unable to close ', file_name, ' (FIXCRC)') );

    ! release job-file-number
    rljfn (.jfn);

%fi

%if VaxVms %then

    !+
    !  This section is not used by TOPS-20 because of XPORT related
    !  problems.  XPORT does some buffering behind the scene so the
    !  jfn in iob$h_channel can not be used in conjunction with certain
    !  jsysi, such as rfptr and gtsts.
    !-

    !+
    !  Open and scan the file for a checksum record.
    !-

    ! Open the file

    if not (status = ($cms_open ( iob = rd_iob, file_spec = file_name,
			  failure = 0 )) )
    then
	begin
	erssts(s_inoopen,.status, cat('Cannot open input file ',file_name));
	return false;
	end;


    !+
    !  Read every record in the file until you get the end of the file
    !  or until you get to a record containing the checksum data.
    !  The position in the file is saved for the truncation operation.
    !  NOTE that for VMS the position of a record is saved after the record
    !  has been read, but for TOPS-20 the position must be saved before
    !  the read is done.
    !-

    until 
	begin

        %if Tops20 %then

	LOCAL
	    jfn,
	    error_code,
	    ret_code;

	! get current file pointer
 	jfn = .rd_iob[iob$h_channel];
	ret_code = rfptr (.jfn; error_code, fbsiz);
	if .ret_code eql 0
	then
	    bugsts(.error_code,
		   lit('Unable to get file-pointer from RFPTR jsys'));

	%if debug %then
	$xpo_put_msg (string = $str_concat ('FIXCRC: file-pointer = ',
					    $str_ascii(.fbsiz) ));
	%fi
	%fi

	$step_get (iob = rd_iob ) eql step$_eof
	end
    do 
	begin


	!Is it the checksum record?  If so, set a flag to handle
	!the encountered checksum record, define the RAB, and save
	!the rfa

	if ch$eql( 4, ch$ptr(uplit('*/C:')),4,.rd_iob[iob$a_string])
	then

	    begin
	    f_cksum = true;

	    %if %bliss(bliss32) %then

	    save_rab = .rd_iob[iob$a_rms_rab];	!define the RAB

	    ch$move(rab$s_rfa,ch$ptr(save_rab[rab$w_rfa]),ch$ptr(save_rfa));

	    %fi

	    exitloop ;	 

	    end;	    
	end ;

    !Test to see if checksum was encountered.  If so, that checksum
    !record must be truncated from the file.
    
    $cms_close ( iob = rd_iob);

    If .f_cksum then
	truncate (file_name,
		  %if VaxVms %then save_rfa %fi %if Tops20 %then fbsiz %fi,
		  bugsts);

%fi

    !+
    !  The file now has no checksum.  A new one must be added to
    !  the file, and so the crc is set up and appended
    !-

    ! set up the crc that is desired for the now truncated file

    ptr = ch$move( 4,ch$ptr(uplit('*/C:')),ch$ptr(num_buf));
    len = hexasz(.crc, .ptr, 8) ;
    ptr = ch$plus( .ptr, .len);
    ch$wchar(%c' ', .ptr);
    len = .len + 5;


    if not (status = ($cms_open ( iob = wrt_iob, file_spec = file_name,
				  options = append,failure = 0 )) )
    then
	begin
	erssts(s_oanoopen,.status, cat('Cannot open output file ',
					file_name, ' for append'));
	return false;
	end;

    ! Register file
    trnfil ( wrt_iob) ;    

    !Append the newly-calculated crc to the file

    $step_put ( iob = wrt_iob,
	       string = (.len, ch$ptr(num_buf)),
	       failure = 0 );

    ! Close the file

    $cms_close ( iob = wrt_iob );

    !+
    ! The file now has been "fixed", ie, it has had the old checksum 
    ! truncated from it and a new checksum appended to it.  It should
    ! now be correct.
    !-


! Inform the user - Check for control files and issue special messages for those
    if d_custom_msg eqla k_null
    then
	fresad(say(cat('***Repaired checksum for file ',file_name)))
    else
	say(d_custom_msg);


    begin

    !
    !  KLUDGE: Routine TRNFIL is a nop unless the file has just been
    !  created.  Since we just appended to a file, TRNFIL did not mark
    !  it as closed by CMS.  Get the official transaction time and
    !  try to fix the file-header.  FIXHDR may have already been called
    !  once for this file, if so the user will see the "header repaired"
    !  message twice.
    !

    external routine
	trntim : novalue;		! get official transaction time
    local
	trnx_time: time_block;		! hold official transaction time

    trntim (trnx_time);	
    fixhdr (file_name, trnx_time);
    end;

    true

    end;			!End of routine FIXCRC

global routine fixhdr (r_file_spec,time_val) =

!++
! Functional Description:
!
!
!	This routine updates the file as specified with a revision number of
!	2, and the given time. If no time is given, the time that already
!	exists is used.
!
! Formal Parameters:
!
!	r_file_spec - Address of file descriptor.
!	time_val - time to be used to reset time
!
! Implicit Inputs:
!
!	The logical name fac_name$LIB is assumed to denote a library.
!
! Implicit Outputs:
!
!	None
!
! Routine Value:
! Completion Codes:
!
!	TRUE - header fixed up correctly
!	FALSE - header fixup failed
!
! Side Effects:
!
!	None.
!
!--

    begin	! FIXHDR

    local
	directory : desc_block,		! Directory of expanded specification.
	expanded : desc_block;		! Descriptor of expanded specification,
					! explained below.

    map
	r_file_spec : ref desc_block,	! File specification passed
	time_val : ref time_block;

%if %bliss(bliss32) %then

    local
    	r_xabrdt : ref $xabrdt_decl,
	status ;			! System service status code.

    own
	expanded_str : vector[ch$allocation(nam$c_maxrss)],
					! Expanded file specification returned
					! by $PARSE.  It fully identifies a
					! directory, but the rest of the 
					! specification has only been checked
					! for syntax.
	resultant_str : vector[ch$allocation(nam$c_maxrss)],
					! Full file specification returned by
					! $SEARCH
	nam : $nam(esa = expanded_str, ess = nam$c_maxrss,
			rsa = resultant_str, rss = nam$c_maxrss),
					! Name block for RMS.
	xabrdt : $xabrdt(),		! Extended attribute block for RMS.
	fab : $fab(fac = put, nam = nam, xab = xabrdt) ;
					! File access block pointing to the
					! name block and xab block just
					! declared.

    ! Have RMS check the file specification and find the directory.
    fab[fab$b_fns] = .r_file_spec[desc_len] ;
    fab[fab$l_fna] = .r_file_spec[desc_ptr] ;
    if
	not (status = $parse(fab = fab))
    then
	begin
	fresad(errsts(s_repairfai,.status, cat('***Cannot repair ',
			.r_file_spec)));
	return false
	end
    else
	begin	! Search.

	! Find the directory portion of the expanded file specification.
	$str_desc_init(descriptor = expanded,
		    string = (.nam[nam$b_esl], .nam[nam$l_esa])) ;
	dirspc(expanded, directory) ;

	! Process the file
	if
	    not (status = $search(fab = fab))
	then
	    bugsts(.status, cat('FIXHDR cannot search ', directory)) ;

	! Get some of the file's characteristics.
	fab[fab$v_nam] = 1 ;	! Tell RMS to use the NAM block.
	if
	    not (status = $open(fab = fab))
	then
	    begin
	    fresad(errsts(s_repairfai,.status, cat('***Cannot repair ',
		(.nam[nam$b_rsl], .nam[nam$l_rsa])))) ;
	    return false
	    end;

	! Set revision number to 2
	xabrdt[xab$w_rvn] = 2 ;

	! Set the specified time
	timcop(.time_val,xabrdt[xab$q_rdt]);

	! Close the file
	if
	    not ( status = $close ( fab = fab))
	then
 	    BEGIN
 	    IF .status EQL rms$_prv
 	    THEN
 		BEGIN
	    	fresad(errsts(s_repairfai,.status, cat('***Cannot repair ',
		      (.nam[nam$b_rsl], .nam[nam$l_rsa]),' ;you must own the file'))) ;
 		RETURN false;
 		END
 	    ELSE
	    	bugsts( .status, cat('FIXHDR cannot close ',
		      (.nam[nam$b_rsl], .nam[nam$l_rsa]))) ;
 	    END;

	end ;
%fi

%if %bliss(bliss36) %then
    %if %switches(tops20) %then

    local
	file_z_ptr,			! pointer to asciz string
	handle: block[1],		! JFN and flags
	next_handle,			! JFN and flags
	temp;				! flags

    cvtas0( .r_file_spec, file_z_ptr) ;

    ! get the JFN for the file
    temp = gj_sht or gj_old or gj_ifg or gj_flg ;
    if
	gtjfn( .temp, .file_z_ptr; handle ) neq 1
    then
	begin
	fresad(errsts(s_repairfai,.handle, cat('***Cannot repair ',
		    .r_file_spec)));
	return false
	end
    else
	begin
	! Process the file

	local
	    error_num,		! error status
	    internal_time,	! internal date and time
	    new_mark,		! JFN and index and update flag	    
	    new_time;		! jfn and update flags

	! Set the revision mark to 'S'
	new_mark = hwf($fbusw, .handle);
	if
	    not chfdb ( .new_mark, -1, %c'S' ) 
	then
	    begin
	    geter ( $fhslf ; error_num );
	    fresad(erssts (s_nosetrev, .error_num, 
		cat( '***Cannot set the revision mark for ',.r_file_spec))) ;
	    return false
	    end ;

	timcop (.time_val, internal_time);

	! Change the FBD
	new_time = hwf($fbwrt, .handle);
	if
	    not chfdb ( .new_time, -1, .internal_time) 
	then
	    begin
	    geter ( $fhslf ; error_num) ;
	    fresad(erssts (s_timenoset, .error_num,
	    cat('***Cannot set the time for ',.r_file_spec))) ;
	    return false
	    end ;

	! release the jfn
	rljfn (.handle);

	end ;

    %else
	%error(ds-10 support not implemented)
    %fi
%fi

    !Give user a message
    fresad(SAY(CAT('***Repaired header for file ',.r_file_spec)));

    true

    end ;	! fixhdr

	
end		! Module FIXUP
eludom