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

MODULE setcls	(
    		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 processing the SET 
!	CLASS Command.
!
! ENVIRONMENT: VAX/VMS, DS-20
!
! AUTHOR: D. Knight
!
!--

!
! TABLE OF CONTENTS:
!

FORWARD ROUTINE
	s_cls;			! main set class processing

!
! INCLUDE FILES:
!
%if 
    %bliss(bliss32) 
%then
    library 'sys$library:starlet';
%else
    require 'jsys:';
%fi

library 'xport:';

require 'sconfg:';

require 'blissx:';

require 'comusr:';

require 'hosusr:';

require 'shrusr:';

require 'logusr:';

!
! MACROS:
!

!
! EQUATED SYMBOLS:
!

!
! OWN STORAGE:
!
    
own
    $io_block(in),		! input iob
    $io_block(out) ;	! output iob

own
    d_elmnam: desc_block;	! element name string


!
! EXTERNAL REFERENCES:
!

external literal

	s_invcksum,		!class file has invalid checksum	
	s_existcls,		!file already exists
	s_noclassf,		!no class found
	s_nocksum,		!class file has no checksum
	s_spcqual,		!no qualifiers present
	s_stcls;		!attributes modified ok

external routine
    aschex,			! ASCII to hex(ASCDEC)
    badlib,			! write bad library message(TERMIO)
    badxpo,
    begtrn,			! begin tranaction(TRANSA)
    bug,			! print bug message(TERMIO)
    cantrn,			! cancel tranaction(TRANSA)
    crccalc,			! calculate CRC of a sting(CRCOPS)
    crctable,			! set up polynomial table (CRCOPS)
    delvrs,			! delete files(FILOPS)
    donlib,			! release library(SHARE)
    endtrn,			! end transaction(TRANSA)
    ers,			! print error message(TERMIO)
    exits,			! exit silently
    get_lxm,
    hexasz,			! Hex to ASCII (DECASC)
    logtrn,			! log transaction(IOLOG)
    saflib, 			! request access to library(SHARE)
    sysmsg,
    trnfil;			! register file for error recovery(TRANSA)

global ROUTINE S_cls (par,qual) =

!++
! FUNCTIONAL DESCRIPTION:
!
!	This is the main routine that performs the functions of the SET
!	CLASS Command.
!
! FORMAL PARAMETERS:
!
!	par - address of first parameter block
!	qual - address of qualifier block
!
! IMPLICIT INPUTS:
!
!	None.
!
! IMPLICIT OUTPUTS:
!
!	None.
!
! ROUTINE VALUE and
! COMPLETION CODES:
!
!	k_success = successful completion
!	k_silent_error = error in processing
!
! SIDE EFFECTS:
!
!	None.
!
!--

    BEGIN

    map
	par : ref parameter_block,
	qual : ref qualifier_block;

    local
	cls_nm_buf : vector[ch$allocation(el_nam_size)],
	CLS_NM_LGT,
	cls_found,			!true if specified class was found
	cls_pnt,
  	crc_len,			!length of file count control line
	crc_buf:vector[ch$allocation(max_num_size + 5)], 	!space to build CRC control line
	crc_ptr,			!pointer to CRC control line
	d_delfil: desc_block,		! file name delvrs is to delete
	existing_crc,			! File count already in input file
	found_crc,			! Found a file count if true
	new_crc,			! File count of output file
	old_crc,			! File count of input file
	ro_qual,			!true if /readonly was entered
	status;

    if
	.qual eql k_null
    then
	begin
	ers(s_spcqual,lit('Missing qualifiers'));
	return k_silent_error
	end
    else
    if
	.qual[qua_code] eql k_read_qual
    then
	ro_qual=true
    else
    if
	.qual[qua_code] eql k_noread_qual
    then
	ro_qual=false
    else
	bug(lit('Funny qualifier in S_CLS'));

    !Try for access to the library
    IF
	NOT SAFLIB(K_UPDATE_LIB)
    THEN
	RETURN K_SILENT_SEVERE;
    
    !Correct class not yet seen
    cls_found=false;
    cls_nm_lgt=0;
    
    ! Initialize CRC stuff
    existing_crc = 0;
    found_crc = false;
    new_crc = 0;
    old_crc = 0;
    ! Set up polynomial table for CRC calculations
    crctable();

    ! initialize deletion descriptor
    $str_desc_init(descriptor=d_delfil,string=(%string(lib,atf))) ;

    ! begin transaction
    begtrn() ;
    
    ! open input
    if
	(status=$step_open(iob=in_iob,file_spec=(%string(lib,atf)),
		options=input,failure=0)) neq step$_normal
    then
	badxpo(.status,lit('Cannot open class file.'));
    
    ! open output
    if
	(status=$step_open(iob=out_iob,file_spec=(%string(lib,atf)),
		options=output,failure=0)) neq step$_created
    then
	badxpo(.status,lit('Cannot open new class file.'));
    
    ! register file for error recovery
    trnfil(out_iob) ;
    
    until
    	$step_get(iob=in_iob) eql step$_eof
    do
    	begin	! main read loop
    
	LOCAL
	    qual_buf : vector[ch$allocation(10)],
	    qual_lgt;
  	!Check for control line 
	if ch$eql(4,ch$ptr(uplit('*/C:')),4,.in_iob[iob$a_string])
	then
	    begin
	    local
		len,
		ptr ;
	    len = .in_iob[iob$h_string] - 4;
	    ptr = ch$plus(.in_iob[iob$a_string], 4) ;
	    existing_crc = aschex(ptr, len) ;
	    found_crc = true;
	    exitloop 
	    end;

	! Calculate the CRC of this line
	old_crc = .old_crc +
		 crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]);

	! after we find the correct entry, we don't have to check again
	IF
	    (CH$RCHAR(.IN_IOB[IOB$A_STRING]) NEQ %C' ') and
	    not .cls_found
	THEN
	    BEGIN	! non-blank means class record

	    local
		buf_pnt,
		lin_ptr,
		lin_siz;

	    lin_ptr=.in_iob[iob$a_string];
	    lin_siz=.in_iob[iob$h_string];

	    !get the class name
	    buf_pnt=ch$ptr(cls_nm_buf);
	    cls_nm_lgt=get_lxm(lin_ptr,%c' ',.lin_siz,buf_pnt);
	    lin_siz=.lin_siz-.cls_nm_lgt-1;

	    !re-construct the line if it is the correct class
	    if
		ch$eql(.par[par_text_len],.par[par_text_ptr],
			.cls_nm_lgt,ch$ptr(cls_nm_buf))
	    then
		begin

		local
		    bld_line : vector[ch$allocation(300)],
		    bld_ptr;

		!see if we are out of text
		if
		    .lin_siz gtr 0
		then
		    begin

		    !check for "/READ_ONLY" already in place
		    if
			%if %bliss(bliss32) %then
			ch$eql(11,ch$ptr(uplit('/READ_ONLY ')),11,.lin_ptr)
			%fi
			%if %bliss(bliss36) %then
			ch$eql(11,ch$ptr(uplit('/READ-ONLY ')),11,.lin_ptr)
			%fi
		    then
			begin
			if
			    .ro_qual
			then
			    !already there, let user know
			    ers(s_existcls,cat('Class ',
				(.cls_nm_lgt,ch$ptr(cls_nm_buf)),
				%if %bliss(bliss32) %then
		                ' is already READ_ONLY'));
				%fi
				%if %bliss(bliss36) %then
		                ' is already READ-ONLY'));
				%fi
			lin_ptr=ch$plus(.lin_ptr,11);
			lin_siz=.lin_siz-11
			end
		    else
			if
			    not .ro_qual
			then
			    ers(s_existcls,cat('Class ',
				    (.cls_nm_lgt,ch$ptr(cls_nm_buf)),
				%if %bliss(bliss32) %then
				    ' is already NOREAD_ONLY'))
				%fi
				%if %bliss(bliss36) %then
				    ' is already NOREAD-ONLY'))
				%fi
		    end;

		!copy the name
		bld_ptr=ch$move(.cls_nm_lgt,ch$ptr(cls_nm_buf),ch$ptr(bld_line));
		ch$wchar_a(%c' ',bld_ptr);

		!if it is read-only, add the qualifier
		if
		    .ro_qual
		then
		    %if %bliss(bliss32) %then
		    bld_ptr=ch$move(11,ch$ptr(uplit('/READ_ONLY ')),.bld_ptr);
		    %fi
		    %if %bliss(bliss36) %then
		    bld_ptr=ch$move(11,ch$ptr(uplit('/READ-ONLY ')),.bld_ptr);
		    %fi

		!now add the comment field
		if
		    .lin_siz gtr 0
		then
		    bld_ptr=ch$move(.lin_siz,.lin_ptr,.bld_ptr);

		!and output the altered line
		cls_found=true;

		new_crc = .new_crc +
		 	crccalc( ch$diff(.bld_ptr,ch$ptr(bld_line)), ch$ptr(bld_line));

		$step_put(iob=out_iob,string=(ch$diff(.bld_ptr,ch$ptr(bld_line)),
						ch$ptr(bld_line)));
		end
	    else
		!The line does not get changed so just put it away
		begin
		new_crc = .new_crc +
		 	crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]);
		$step_put(iob=out_iob,string=in_iob[iob$t_string]);
		end

	    end		! non-blank means class record
	else
	    !write out any records that we don't need

	    begin
	    new_crc = .new_crc +
	 	crccalc( .in_iob[iob$h_string], .in_iob[iob$a_string]);
	    $step_put(iob=out_iob,string=in_iob[iob$t_string]);
	    end;

	end ;	! main read loop
	
    $step_close(iob=in_iob,options=remember) ;


    !Write out newly calculated CRC
    crc_ptr = ch$move(4,ch$ptr(uplit('*/C:')),ch$ptr(crc_buf));
    crc_len = hexasz( .new_crc, .crc_ptr, 8);
    crc_ptr = ch$plus(.crc_ptr, .crc_len) ;
    ch$wchar(%c' ',.crc_ptr);
    crc_len = .crc_len + 5;
    $step_put( iob = out_iob, string = (.crc_len, ch$ptr(crc_buf)),
		failure = 0 );
    !Close the output file
    $step_close(iob=out_iob,options=remember) ;

    ! Check for valid file counts
    if not .found_crc 
    then
	sysmsg(s_nocksum,cat('Classfile has no checksum'),0)
    else
	if .existing_crc neq .old_crc
        then
	    sysmsg(s_invcksum,cat(' Class file has an invalid checksum'),0);

    if
    	not .cls_found
    then
    	begin	! record not found
    	cantrn() ;
    	$step_delete(iob=out_iob) ;
    	ers(s_noclassf,cat('Class ',(.par[par_text_len],.par[par_text_ptr]),
				' does not exist'));
    	donlib() ;
    	return k_silent_error ;
    	end	! record not found
    else
    	begin	! record updated
    
    	! delete old def file
    	delvrs(filvrs,.d_delfil[desc_len],.d_delfil[desc_ptr]) ;
    
    	! write log record
    	logtrn(k_normal_log,0,K_null);
    
    	endtrn() ;
    	donlib() ;
    	end ;	! record updated
    
    ! write successful completion message
    cls_pnt = ch$ptr(cls_nm_buf) ;
    if
	.ro_qual
    then
	sysmsg(s_stcls,cat('Class ',(.cls_nm_lgt,.cls_pnt),
		%if %bliss(bliss32) %then
		' set to READ_ONLY'),0)
		%fi
		%if %bliss(bliss36) %then
		' set to READ-ONLY'),0)
		%fi
    else
	sysmsg(s_stcls,cat('Class ',(.cls_nm_lgt,ch$ptr(cls_nm_buf)),
		%if %bliss(bliss32) %then
		' set to NOREAD_ONLY'),0) ;
		%fi
		%if %bliss(bliss36) %then
		' set to NOREAD-ONLY'),0) ;
		%fi

    exits(s_stcls)
    
    END;			! end of routine S_CLS

END				! End of module
ELUDOM