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 ( https://neilrieck.net/ )
! 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 ! signed quad word
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 ! defined 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 HomeNeil Rieck
Waterloo, Ontario, Canada.