OpenVMS Source Code Demos

Multi-line_logicals_Demo.bas

1000	%title "basic-demo-ml-logicals"						!
	%ident                      "version_100.3"				!
	declare string constant k_version = "100.3"			,	!				&
				k_program = "basic-demo-ml-logicals"		!
	!==============================================================================================================
	! title  : basic-demo-ML-LOGICALS_100.BAS
	! author : Neil Rieck ( http://www3.sympatico.ca/n.rieck/ )
	! created: 2011-04-06
	! notes  : 1) Certain OpenVMS apps like Apache will attempt to create a symbol which is passed via GCI to user
	!	   written apps. One example is "cookie data" which is stored as symbol HTTP_COOKIE. Unfortunately this
	!	   is limited in length to 970 bytes. However, if you execute the following DCL command:
	!		$define/system APACHE$CGI_MODE 1
	!	   prior to starting/restarting Apache, then data strings greater than 970 bytes are stored as
	!	   multi-line logical names. This program demos the programatic creation / consumption of data produced
	!	   that way.
	!	 : 2) refresher this is how you create multi-line logicals from DCL:
	!		$define YADA abc,def,"ghi"	!! use quotes to preserve case
	!	   and here is what one looks like:
	!		$show log yada
	!		   "YADA" = "ABC" (LNM$PROCESS_TABLE)
	!		        = "DEF"
	!		        = "ghi"
	!
	! ver who when     what
	! --- --- -------- --------------------------------------------------------------------------------------------
	! 100 NSR 20110406 1. original work (a spare time effort)
	!     NSR 20110408 2. more work
	!     NSR 20110414 3. more work
	!==============================================================================================================
	option type=explicit							! no kid stuff
	set no prompt								!
	!
	%include "starlet"      %from %library "sys$library:basic$starlet"	! system services (including basic$quadword)
	%include "lib$routines" %from %library "sys$library:basic$starlet"	! lib$
	%include "$libdtdef"    %from %library "sys$library:basic$starlet"	! lib$k
	%include "$lnmdef"      %from %library "sys$library:basic$starlet"	! logical name definitions
        !
        !       note: for this little trick to work, we must...
        !
        !               1. declare LONG BY VALUE passing mechanism here (we are passing 32-bit addresses)
        !               2. declare basic$quadword BY REF passing mechanism in the receiving functions
        !
	external basic$quadword function my_peek_Q( long by value )		!
	!
	!	create a new "data type" for use in a parameter list further down
	!
	record ItemRec								! structure of an item record
	    variant								! yikes, what's this? :-)
		case								!
		    group one							! here's one way to look at it
			word    BuffLen						!
			word    ItemCode					!
			long    BuffAddr					!
			long    RtnLenAdr					!
		    end group one						!
		case								!
		    group two							! here's a second way to look at it
			long    List_Terminator					!
			long    Junk1						!
			long    Junk2						!
		    end group two						!
	    end variant								!
	end record ItemRec							!
	!
	%include "$dscdef"      %from %library "sys$library:basic$starlet"      ! descriptor stuff
	record switcheroo
	    variant
		case
		    group one							!
			basic$quadword	my_quad					!
		    end group							!
		case								!
		    group two							!
			word	my_len						! length
			byte	my_typ						! type
			byte	my_class					! class
			long	my_addr						! address
		    end group							!
		case								!
		    group three							!
			DSCDEF1	my_descriptor					! definied in $dscdef in sys$library:basic$starlet
		    end group							!
	    end variant								!
	end record								!
	!
	declare switcheroo my_dsc						! declare a variable to match the new record
	!
	declare long	rc%, index%, max_index%, pass%, i%, num_names%, ptr%	!
	declare word	result_length%						!
	declare string	table$, temp$, result$					!
	declare string  logical_name$, logical_data$				!
	declare string	pgm_mode$, cmd$, junk$					!
	!
	!=======================================================================
	!	main
	!=======================================================================
2000	main:
	print k_program +"_"+ k_version						!
	print string$(len(k_program +"_"+ k_version), asc("="))			! what will the optimizer do with this?
	print
	print "Create logicals menu"						!
	print "===================="						!
	print "0 = do nothing here but continue"				!
	print "1 = create a single logical    via lib$set_logical (dynamic string)"
	print "2 = create multi-line logicals via lib$set_logical (static strings)"
	print "3 = create multi-line logicals via lib$set_logical (dynamic strings)"
	print "4 = create multi-line logicals via sys$crelnm      (dynamic strings)"
	print "Choice (0-4,default=exit) ";					!
	input pgm_mode$								!
	select edit$(pgm_mode$,4+2)						!
	    case "0" to "4"							!
	    case else								!
		goto fini							!
	end select								!
	!
	!	create a single logical via lib$set_logical
	!
	if pgm_mode$ = "1" then							! single logical via lib$set_logical
	    table$		= "LNM$PROCESS_TABLE"				!
	    logical_name$	= "YADA"					!
	    logical_data$	= "ABC123"					!
	    !
	    ! LIB$SET_LOGICAL logical-name [,value-string] [,table] [,attributes] [,item-list] 
	    !
	    rc% = lib$set_logical(logical_name$, logical_data$, table$,,)	!
	    if (rc% and 7%) <> 1 then						!
		print "-e-rc: ";rc%;" low bits: ";(rc% and 7%)			!
		goto fini							!
	    else								!
		print "-i-rc: ";rc%;" low bits: ";(rc% and 7%)			!
	    end if								!
	end if									!
	!
	!	create multi-line logicals via lib$set_logical (static strings)
	!
	if pgm_mode$ = "2" then							! multi-line logicals via lib$set_logical
	    !
	    table$		= "LNM$PROCESS_TABLE"				!
	    logical_name$	= "YADA"					!
!~~~	    logical_data$	= "ABC123"					x not used here
	    !
	    !	data for a multi-line logical
	    !
	    map(xyz) string b$(20) = 20						!
	    dim long L(20)							! need this array to remember lengths
	    !
	    junk$ = "123"							! data to write
	    b$(0) = junk$							!
	    L(0) = len(junk$)							!	    
	    !
	    junk$ = "4567"							!
	    b$(1) = junk$							!
	    L(1) = len(junk$)							!
	    !
	    junk$ = "89012"							!
	    b$(2) = junk$							!
	    L(2) = len(junk$)							!
	    !
	    junk$ = "345678"							!
	    b$(3) = junk$							!
	    L(3) = len(junk$)							!
	    !
	    num_names% = 4							!
	    !
	    dim ItemRec ItemBuf1(num_names%)					! 0 -> 4 list items
	    !
	    !	manually populate the Item Buffer just to show how it's done 
	    !
	    ItemBuf1(0)::BuffLen	= L(0)					! string length
	    ItemBuf1(0)::ItemCode	= lnm$_string				! 
	    ItemBuf1(0)::BuffAddr	= loc(b$(0))				! string address
	    ItemBuf1(0)::RtnLenAdr	= 0					! not used
	    !
	    ItemBuf1(1)::BuffLen	= L(1)					!
	    ItemBuf1(1)::ItemCode	= lnm$_string				!
	    ItemBuf1(1)::BuffAddr	= loc(b$(1))				!
	    ItemBuf1(1)::RtnLenAdr	= 0					!
	    !
	    ItemBuf1(2)::BuffLen	= L(2)					!
	    ItemBuf1(2)::ItemCode	= lnm$_string				!
	    ItemBuf1(2)::BuffAddr	= loc(b$(2))				!
	    ItemBuf1(2)::RtnLenAdr	= 0					!
	    !
	    ItemBuf1(3)::BuffLen	= L(3)					!
	    ItemBuf1(3)::ItemCode	= lnm$_string				!
	    ItemBuf1(3)::BuffAddr	= loc(b$(3))				!
	    ItemBuf1(3)::RtnLenAdr	= 0					!
	    !
	    ItemBuf1(4)::List_Terminator= 0					! end the list (mandatory)
	    !
	    ! LIB$SET_LOGICAL logical-name [,value-string] [,table] [,attributes] [,item-list] 
	    !
	    rc% = lib$set_logical(logical_name$, "", table$,,ItemBuf1(0) )	!
	    if (rc% and 7%) <> 1 then						!
		print "-e-rc: ";rc%;" low bits: ";(rc% and 7%)			!
		goto fini							!
	    else								!
		print "-i-rc: ";rc%;" low bits: ";(rc% and 7%)			!
	    end if								!
	end if									!
	!
	!	create multi-line logicals via lib$set_logical (dynamic strings)
	!
	if pgm_mode$ = "3" then							! multi-line logicals via lib$set_logical
	    !
	    table$		= "LNM$PROCESS_TABLE"				!
	    logical_name$	= "YADA"					!
!~~~	    logical_data$	= "ABC123"					x not used here
	    !
	    !	data for a multi-line logical
	    !
	    num_names% = 4							! prep for run-time allocation
	    dim string a(num_names%)						! but will only use 0-3
	    a(0) = "ABC"							! data to write
	    a(1) = "DEFG"							!	''
	    a(2) = "HIJKL"							!	''
	    a(3) = "MNOPQR"							!	''
	    !
	    dim ItemRec ItemBuf2(num_names%)					! 0 -> 4 items
	    !
	    for i% = 0 to num_names% - 1					!
		ptr%    = loc( a(i%) )						! ptr% is a pointer to string descriptor
		my_dsc::my_quad = my_peek_Q( ptr% )				! stuff our switcheroo
		!
		ItemBuf2(i%)::BuffLen	= my_dsc::my_len			!
		ItemBuf2(i%)::ItemCode	= lnm$_string				! 
		ItemBuf2(i%)::BuffAddr	= my_dsc::my_addr			!
		ItemBuf2(i%)::RtnLenAdr	= 0					! not used
	    next i%								!
	    !
	    ItemBuf2(num_names%)::List_Terminator = 0				! this is very important
	    !
	    ! LIB$SET_LOGICAL logical-name [,value-string] [,table] [,attributes] [,item-list] 
	    !
	    rc% = lib$set_logical(logical_name$, "", table$,,ItemBuf2(0) )
	    if (rc% and 7%) <> 1 then						!
		print "-e-rc: ";rc%;" low bits: ";(rc% and 7%)			!
		goto fini							!
	    else								!
		print "-i-rc: ";rc%;" low bits: ";(rc% and 7%)			!
	    end if								!
	end if									!
	!
	!	create multi-line logical names via sys$crelnm
	!
	%include "$psldef" %from %library "sys$library:basic$starlet"		!
	if pgm_mode$ = "4" then							! single logical via lib$set_logical
	    num_names% = 4							! prep for run-time allocation
	    dim string c(num_names%)						! but will only use 0-3 elements
	    c(0) = "abc"							! data to write
	    c(1) = "defg"							!	''
	    c(2) = "hijkl"							!	''
	    c(3) = "mnopqr"							!	''
	    !
	    dim ItemRec ItemBuf3(num_names%)					! 0 -> 4 items
	    table$		= "LNM$PROCESS_TABLE"				!
	    logical_name$	= "YADA"					!
	    !
	    for i% = 0 to num_names% - 1					!
		ptr%    = loc( c(i%) )						! ptr% is a pointer to string descriptor
		my_dsc::my_quad = my_peek_Q( ptr% )				! stuff our switcheroo
		!
		ItemBuf3(i%)::BuffLen	= my_dsc::my_len			!
		ItemBuf3(i%)::ItemCode	= lnm$_string				! 
		ItemBuf3(i%)::BuffAddr	= my_dsc::my_addr			!
		ItemBuf3(i%)::RtnLenAdr	= 0					! not used
	    next i%								!
	    !
	    ! SYS$CRELNM [attr] ,tabnam ,lognam ,[acmode] ,[itmlst] 
	    !
	    rc% = sys$crelnm(,table$,logical_name$,PSL$C_SUPER,ItemBuf3() )	!
	    if (rc% and 7%) <> 1 then						!
		print "-e-rc: ";rc%;" low bits: ";(rc% and 7%)			!
		goto fini							!
	    else								!
		print "-i-rc: ";rc%;" low bits: ";(rc% and 7%)			!
	    end if								!
	end if									!
	!
	print "========================================"
	print " starting logical reads"
	print "========================================"
	pass% = 0								! init
	table$	= "LNM$PROCESS_TABLE"						!
	!
	loop:									!
	pass% = pass% + 1							!
	select pass%								!
	    case 1 								!
		logical_name$ = "YADA"						!
	    case 2								!
		logical_name$ = "OOPS"						! this one does not exist
	    case else								!
		goto fini							!
	end select								!
	print "========================================"
	print "-i-starting pass: "+ str$(pass%)
	print "-i-logical_name : "+ logical_name$
	print "-i-table        : "+ table$
	!
	! LIB$GET_LOGICAL logical-name [,resultant-string] [,resultant-length] [,table-name]
	!	 [,max-index] [,index] [,acmode] [,flags] 
	!
	! Note: when this call is done this way, two things happen:
	!	1) we test for the desired logical and return the first (zeroeth) equivalent data
	!	2) max_index% will tell us the highest index to return
	!
	rc% = lib$get_logical(logical_name$, temp$, result_length%, table$, max_index%,,,)	! assume index=0
	if (rc% and 7%) = 1 then						!
		result$ = temp$							!
		print "-i-max_index%     ";str$(max_index%);" ";		!
		if max_index% = 0 then						!
		    print " (single-line logical)"				!
		else								!
		    print " (multi-line logical)"				!
		end if								!
		print "-i-index          0"					!
		print "-i-temp$          ";temp$				!
	else									!
		temp$ = ""							!
		result_length% = 0						!
		max_index% = 0							! zap
		print "-e-rc: ";rc%;" low bits: ";(rc% and 7%)			!
	end if									!
	!
	if max_index% >= 1 then							! if multi-line logicals exist...
	    for index% = 1 to max_index%					! step thru logcial names
		!
		!	note: when done this way, index% returns the desired line (one of many)
		!
		rc% = lib$get_logical(logical_name$, temp$, result_length%, table$, max_index%, index%,)
		if (rc% and 7%) = 1 then					!
		    print "-i-index          ";str$(index%)			!
		    print "-i-temp$          ";temp$				!
		    result$ = result$ + temp$					!
		else								!
		    print "-e-rc: ";rc%;" low bits: ";(rc% and 7%)		!
		end if								!
	    next index%								!
	end if									!
	!
	goto loop								! loop back for more tests
	!=======================================================================
	!	That's all she wrote
	!=======================================================================
32000	fini:									!
	print "Adios..."							!
	end									!
	!
	!-----------------------------------------------------------------------
	!	peek Q/uadword
	!-----------------------------------------------------------------------
32030	function basic$quadword my_peek_Q(basic$quadword incomming by ref)	! basic$quadword function receives quad address
	option type=explicit							!
	%include "starlet"      %from %library "sys$library:basic$starlet"      ! system services (and basic$quadword)
	my_peek_Q =  incomming							! exit with this value
	end function								!

Back to OpenVMS
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.