OpenVMS Source Code Demos

VMS_BASIC_DISPLAY_SYSTEM_ERROR.BAS

1000	%TITLE 'Display_System_Error.BAS'
	%SBTTL 'Display System Error Message Text For Debugging'
	%IDENT 'Version_103'
	!===============================================================================================================
	! Title  : vax_basic_display_system_error.bas
	! Author : Neil Rieck (Waterloo, Ontario, Canada)
	! Purpose: to display VMS error text when presented error numbers
	! History:
	! 100 NSR 871228 Original program
	! 101 NSR 960729 Added support for Hex numbers
	! 102 NSR 991125 Cleanup for publication
	! 103 NSR 000418 Now system service declartions come from BASIC$STARLET
	!===============================================================================================================
	! VMS return code overview (lower 3 bits)
	! ------------------------
	! 0 -w- warning
	! 1 -s- success
	! 2 -e- error
	! 3 -i- informational
	! 4 -f- fatal
	! 5 -?-
	! 6 -?-
	! 7 -?-
	!===============================================================================================================
	Option	type=explicit						! cuz tricks are for kids
	Option	size=(Real Double)					!
	set no prompt							!
	!
	%include "starlet" %from %library "sys$library:basic$starlet"	! system services
	%include "$ssdef"  %from %library "sys$library:basic$starlet"	! ss$
	!
	!	<<< data declarations >>>
	!
	map(xxx)string	my_buf = 256					! (w) text of returned msg (fixed length string)
	!
	declare	word	msglen		,				! (w) length of returned msg		&
		long	flags%		,				! (r) message selector			&
			msgid%		,				! (r) error number			&
			rc%		,				! return code				&
			handler_error%	,				!					&
		string	temp$						!
	!
	!	<<< Initialize >>>
	!
	flags% = 15%							! return all error msg components
	print	cr + lf +	"Display System Error"+	&
		cr + lf +	"====================";
	!
	!	<<< main loop >>>
	!
2000	while 1
		print
		input "Enter system error number (use X prefix for HEX, default=quit)...";temp$
		temp$ = edit$(temp$, 32%+4%+2%)				! upcase, no controls, no white space
		goto Fini if temp$ = ""
		!
		while left$(temp$, 1%)="0"				! if leading zero...
			temp$ = right$(temp$, 2%)			! then drop it
		next
		!
		if left$(temp$,1%)="X" then
			temp$ = right$(temp$,2%)			! drop the 'x'
			gosub hex_to_dec
			iterate if temp$=""
		end if
		!
		when error in
		    msgid% = integer(temp$)
		    handler_error% = 0%
		use
		    handler_error% = err
		end when
		select handler_error%
		    case 0%
		    case 52%
			print ">>> Invalid Number"+ bel
			iterate
		    case else
			print "Error = ";handler_error%
			print "Line  = ";erl
			print "Text  = ";ert$(handler_error%)
			iterate
		end select
		!
		my_buf = ""
		rc% = sys$getmsg(msgid%, msglen, my_buf, flags%,)
		if ((rc% and 7%) <> 1%) then
		    print ">>> internal error: "+ str$(rc%)
		    resume fini
		end if
		print "Msg >>> "; edit$(my_buf, 128%)			! no trailing spaces
	next
	!+
	!================================================================================
	! hex_to_decimal
	!
	! note: this subroutine should be replaced with a call to "OTS$CVT_TZ_L"
	!================================================================================
	!-
	declare string constant hex_chars$ = "0123456789ABCDEF"
	declare long	tally%,	i%, j%, k%
	!
3000	hex_to_dec:
	tally% = 0%
	j% = len(temp$)
	while j% > 0%
		k% = pos(hex_chars$, mid$(temp$,j%,1%), 1%)
		if k% = 0% then
			print bel+"-e- illegal hex character encountered"
			temp$ = ""
			return
		end if
		tally% = tally% + (k%-1%) * 16^(len(temp$)-j%)
		j% = j% - 1%
	next
	temp$ = str$(tally%)
	print "-i- Equiv Decimal Value: ";temp$
	return
	!=======================================================================
	! That's all folks
	!=======================================================================
	Fini:									!
	end

---

Back to Home
Neil Rieck
Waterloo, Ontario, Canada.