OpenVMS Source Code Demos
RMS_TEST_USEROPEN.BAS
1000 %title "RMS_TEST_USEROPEN_xxx.BAS" !
%ident "version_106.1" ! <<<---+---
declare string constant k_version = "version 106.1" , ! <<<---+ &
k_program = "RMS_TEST_USEROPEN" !
!=========================================================================================================================
! Title : RMS_TEST_USEROPEN_xxx.BAS
! Author : Neil Rieck
! Created: 000809
! Notes : 1. using DEC-BASIC's USEROPEN statement to open any type of file then peek at the FAB/RAB locations
! 2. original program from examples in the DEC BASIC for OpenVMS "User's Manual" and "Reference Manual"
! 3. additional info from $FABDEF and $RABDEF found in SYS$LIBRARY:BASIC$STARLET.TLB
! ver who when what
! --- --- ------ ---------------------------------------------------------------------------------------------------------
! 100 NSR 000809 1. original demo
! 101 NSR 010905 1. modified demo to fix text files FTP'd here in BINARY mode (instead of ASCII mode)
! 102 NSR 100531 1. renamed some variables
! 103 NSR 100531 1. added code to test-open GIFs and JPGs (this is just hacking)
! 104 NSR 110506 1. added a menu
! 2. added support for xabsum (to view number-of-keys)
! 105 NSR 110507 1. hacking with XABKEY
! NSR 110825 2. a few teaks
! 106 NSR 110829 1. added support for xabpro (to view file protection bits)
!=========================================================================================================================
option type=explicit !
!
on error goto trap !
!
declare string constant htab = '9'C ! horizontal tab
!
%include "lib$routines" %FROM %LIBRARY "SYS$LIBRARY:BASIC$STARLET" ! lib$spawn
%include "STARLET" %from %library "sys$library:basic$starlet" ! system services
%include "$FABDEF" %from %library "sys$library:basic$starlet" ! File Access Block
!
! this common is used to pass back parameters from the useropen function to this program's main
! and must be identical with the useropen declaration
!
common(rab_ptr) long cmn_org , ! 0 &
long cmn_rat , ! 1 &
long cmn_mrs , ! 2 &
long cmn_alq , ! 3 &
long cmn_bks_bls , ! 4 &
long cmn_num_keys , ! 5 &
long cmn_mrn , ! 6 &
long cmn_rfm , ! 7 &
long cmn_sanity , ! 8 &
string cmn_align = 0 !
common(rab_ptr) long cmn_stuff(8) , ! 8 (subscript zero not counted in BASIC) &
string cmd_align = 0 !
cmn_sanity = loc(cmn_align)-loc(cmn_org) ! prep for sanity test
!
map(my512)string my512$ = 512 !
!
declare string my_file$ , &
temp$ , &
fs$ , &
cmd$ , &
junk$ , &
long junk% , &
pos0% , &
handler_error% , &
rc% , &
cr_pos% , &
span% , &
file_stats% , &
fix_file% !
external long function my_open !
!
! for this peek trick to work...
!
! 1. declare LONG BY VALUE passing mechanisms here (we are passing 32-bit addresses)
! 2. declare BY REF passing mechanisms in the receiving functions
!
external long function my_peek_L( long by value ) !
external long function my_poke_L( long by value, long by value) !
external word function my_peek_W( long by value ) !
external byte function my_peek_B( long by value ) !
external basic$quadword function my_peek_Q( long by value ) !
external long function my_loc( any by ref ) !
!========================================================================================================================
! main
!========================================================================================================================
main:
print
print k_program +"_"+ k_version
print string$(len(k_program +"_"+ k_version), asc("=")) ! what will the optimizer do with this?
!-----------------------------------------------------------------------
! create a list of text files
!-----------------------------------------------------------------------
print
print "file-spec menu"
print "=============="
print " 1 use: *.dat"
print " 2 use: *.txt"
print " 3 use: *.gif"
print " 4 use: *.gif,*.jpg"
print " or just enter a partial (with wildcards) or full filespec"
input "choice? (1-4, or filespec. default=exit) "; fs$ !
fs$ = edit$(fs$,4+2) !
select fs$ !
case "" !
goto fini !
case "1" !
fs$ = "*.dat;" !
case "2" !
fs$ = "*.txt;" !
case "3" !
fs$ = "*.gif;" !
case "4" !
fs$ = "*.gif;,*.jpg;" !
case else !
! entered some filespec
end select !
!
fix_file% = 0 ! init
junk$ = edit$(fs$,32) ! upcase for next tests
junk% = 0 ! init
junk% = 1 if pos(junk$,".TXT",1) > 0 !
junk% = 1 if pos(junk$,".LST",1) > 0 !
if junk% = 1 then !
input "fix text files? (y/N) ";junk$ !
select left$(edit$(junk$,32+2),1) !
case "Y" !
fix_file% = 1 !
end select !
end if !
select fs$ !
case "3" to "4" !
fs$ = "[.*..]"+ fs$ !
end select !
cmd$ = "$dir/out="+ k_program +"_scratch.junk/nohead/notrail "+ fs$ !
print "-i- executing cmd: "+ cmd$ !
sleep 1 !
rc% = lib$spawn(cmd$) !
if (rc% and 7%) <> 1 then
print "-e- lib$spawn: "+ str$(rc%)
end if
when error in !
open k_program +"_scratch.junk" for input as #99, access read, allow none
while 1 !
linput #99, my_file$ !
junk% = pos(my_file$,";",1%) ! locate the version specifier
if junk% > 0 then !
my_file$ = left$( my_file$, junk%-1%) !
end if !
gosub test_file !
next !
use !
handler_error% = err !
end when !
select handler_error% !
case 0, 11 !
case else !
print "-e- handler: ";str$(err) !
end select !
close #99 !
goto fini !
!-----------------------------------------------------------------------
! <<< open the desired file using a "useropen" routine >>>
!
! note: DEC-BASIC's OPEN function will set up the FAB before calling my
! "useropen" routine which will actually do the file OPEN.
!-----------------------------------------------------------------------
test_file: !
mat cmn_stuff = zer ! zap common variables just for fun
cmn_stuff(0) = 0 ! cuz mat never clears subscript zero
!
when error in
print "-i- opening: "+ my_file$
open my_file$ for input as #100 &
,access read &
,allow none &
,recordtype any &
,organization undefined &
,useropen my_open ! <--- note: this is triggered on each open
handler_error% = 0 ! cool
use !
handler_error% = err ! oops
end when !
print "-i- closing #100"
close #100 !
!
file_stats% = 1 !
if file_stats% = 1 then ! change this as required
print "==========================================================="
print "file "; my_file$ !
print "org "; cmn_org; htab; !
select cmn_org !
case = FAB$C_HSH ! 48
print " Hash" !
case = FAB$C_IDX ! 32
print " IDX" !
case = FAB$C_REL ! 16
print " REL" !
case = FAB$C_SEQ ! 0
print " SEQ" !
case else !
print " ???" !
end select !
print "rec fmt "; cmn_rfm; htab; !
select cmn_rfm !
case FAB$C_UDF ! 0
print " undefined/stream binary" !
case FAB$C_FIX ! 1
print " fixed length" !
case FAB$C_VAR ! 2
print " variable length" !
case FAB$C_VFC ! 3
print " variable fixed control" !
case FAB$C_STM ! 4 ( valid only for sequential org )
print " RMS-11 stream" !
case FAB$C_STMLF ! 5 ( valid only for sequential org )
print " LF stream" !
case FAB$C_STMCR ! 6 ( valid only for sequential org )
print " CR stream" !
case else !
print " ???" !
end select !
print "rec attr "; cmn_rat !
print "max rec siz "; cmn_mrs !
print "alloc qty "; cmn_alq !
print "bucket size "; cmn_bks_bls !
print "num of keys "; cmn_num_keys; htab +" (only applies to indexed files)"!
print "max rec num "; cmn_mrn; htab +" (only applies to relative files)"
end if !
!
! if input file is SEQUENTIAL and FIXED then convert it to SEQUENTIAL and VARIABLE
!
! note: a text file with these attributes was probably FTP'd here using BINARY transfer
! rather than ASCII transfer. OpenVMS files are not supposed to have embedded
! paper commands like <cr> and <lf> so remove them and do a print (which RMS
! will write as a <nul> terminated PASCAL string which is what RMS wants)
!
if cmn_org = 0% and ! if sequential &
cmn_rfm = 1% and ! and fixed length &
cmn_mrs = 512% and ! and looks like a BINARY-FTP &
fix_file% = 1 ! and this code is desired
then !
junk% = 0 !
junk% = 1 if pos( edit$(my_file$,32), ".TXT",1) > 0 !
junk% = 1 if pos( edit$(my_file$,32), ".LST",1) > 0 !
goto skip_convert if junk% = 0 !
!
print "-i- about to convert: "; my_file$; " from SEQUENTIAL-FIXED to SEQUENTIAL-VARIABLE"
input "-?- do you wish to continue? (Y/N, default=N )";junk$
select edit$(junk$,32+2)
case "Y","YES"
case else
goto skip_convert
end select
print "-i- opening: "; my_file$
when error in
open my_file$ for input as #95 &
,access read &
,allow none &
,organization sequential fixed &
,recordtype none &
,map my512
!
open my_file$ for output as #90 &
,organization sequential &
,recordsize 32700
!
print "-i- converting file: "+ my_file$
temp$ = "" ! init line buffer
while 1%=1%
pos0% = 1% ! reset scanning pointer
get #95, regardless ! read a block
!
while pos0% < 512% !
cr_pos% = pos(my512$, cr, pos0%) ! find <cr>
if cr_pos% = 0% then ! if <cr> not found...
temp$ = temp$ + seg$(my512$, pos0%, 512%) ! ...then collect to the end of the buffer
pos0% = 512% ! force an inner loop exit
else !
temp$ = temp$ + seg$(my512$, pos0%, cr_pos%-1%) !
temp$ = edit$( temp$, 4%) ! drop controls ( including <lf> + <nul> )
print #90, temp$ if temp$ <> "" ! write line
temp$ = "" !
pos0% = cr_pos%+1% ! skip past the <cr>
end if !
next !
next !
use !
handler_error% = err !
end when !
select handler_error% !
case 0 !
case 11 !
temp$ = edit$( temp$, 4%) ! drop controls
print #90,temp$ if temp$ <> "" ! send last line (if any)
case else !
print "-e- convert error: ";str$(err) !
end select !
end if !
skip_convert:
close #100, #95, #90
return
!-----------------------------------------------------------------------
! common error trap
!-----------------------------------------------------------------------
trap:
print
print "common error handler"
print "-e- error : "+ str$(err)
print "-e- line : "+ str$(erl)
print "-e- text : "+ ert$(err)
print "-e- module: "+ ern$
resume fini !
!-----------------------------------------------------------------------
! <<< adios >>>
!-----------------------------------------------------------------------
32000 fini: !
when error in
print "-i- deleting scratch files"
while 1 !
kill k_program +"_scratch.junk" !
next !
use !
end when !
print "-i- exiting" !
end !
!########################################################################################################################
!
! this function is a USEROPEN routine which is called by BASIC's OPEN statement above
!
32100 function long my_open( FABDEF user_fab, RABDEF user_rab, long channel) !
option type=explicit !
!
%nolist !
%include "STARLET" %from %library "sys$library:basic$starlet" ! system services
%include "$RMSDEF" %from %library "sys$library:basic$starlet" ! Record Management System
%include "$FABDEF" %from %library "sys$library:basic$starlet" ! File Access Block
%include "$RABDEF" %from %library "sys$library:basic$starlet" ! Record Access Block
%include "$XABalldef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABDEF" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABSUMDEF" %from %library "sys$library:basic$starlet" ! Extended Access Block Summary
%include "$XABKEYDEF" %from %library "sys$library:basic$starlet" ! Extended Access Block KEY
%include "$XABcxfdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABcxrdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABdatdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABfhcdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABjnldef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABprodef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABrdtdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABrudef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABitmdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%include "$XABtrmdef" %from %library "sys$library:basic$starlet" ! Extended Access Block
%list !
!
! for this peek trick to work...
!
! 1. declare LONG BY VALUE passing mechanisms here (we are passing 32-bit addresses)
! 2. declare BY REF passing mechanisms in the receiving functions
!
external long function my_peek_L( long by value ) !
external long function my_poke_L( long by value, long by value) !
external word function my_peek_W( long by value ) !
external byte function my_peek_B( long by value ) !
external basic$quadword function my_peek_Q( long by value ) !
external long function my_loc( any by ref ) !
!
! variable declarations
!
declare long rc%, junk%, i%, pass%, preserve%, hook2%, hook9%, ! &
ptr1, p_addr, p_data !
!
declare XABDEF user_xab ! xab block (only used for hacking)
declare XABSUMDEF user_xabsum ! xab summary block (only used for hacking)
declare XABKEYDEF user_xabkey(20) ! xab key block (only used for hacking)
declare XABPRODEF1 user_xabpro ! xab pro block (only used for hacking)
!
! this common is used to pass back parameters from the useropen function to this program's main
! and must be identical with the main declaration
!
common(rab_ptr) long cmn_org , ! 0 &
long cmn_rat , ! 1 &
long cmn_mrs , ! 2 &
long cmn_alq , ! 3 &
long cmn_bks_bls , ! 4 &
long cmn_num_keys , ! 5 &
long cmn_mrn , ! 6 &
long cmn_rfm , ! 7 &
long cmn_sanity , ! 8 &
string cmn_align = 0 !
common(rab_ptr) long cmn_stuff(8) , ! 8 (subscript zero not counted) &
string cmd_align = 0 !
!-----------------------------------------------------------------------
main: !
print "-i- entering my_open (a 'user open' routine)" !
if cmn_sanity <> (loc(cmn_align)-loc(cmn_org)) then !
print "-e- oops, programmer error. The commons do not match" !
end if !
!
mat cmn_stuff = zer ! zap common variables each time thru
cmn_stuff(0) = 0 ! cuz mat never clears subscript zero
!
preserve% = user_fab::fab$l_xab ! save this just in case (for method #0)
print "-i- orig xab addr: "; preserve% !
gosub scan_xab_list ! also defines hook2% on first pass
!-----------------------------------------------------------------------
! in this demo will only use the XABSUM and XABPRO for now
!-----------------------------------------------------------------------
!
! Oops, the following two record components are not properly named in BASIC$STARLET.TLB
!
!~~~ user_xabsum::xab$b_cod = xab$c_sum x init
!~~~ user_xabsum::xab$b_bln = xab$c_sumlen x
!
! Here is what I found in my copy of BASIC$STARLET.TLB (OpenVMS-8.4 with Alpha BASIC 1.7)
!
user_xabsum::xabsumdef$$_fill_1 = xab$c_sum ! init my xabsum
user_xabsum::xabsumdef$$_fill_2 = xab$c_sumlen !
user_xabsum::xabsumdef$$_fill_4 = loc(user_xabpro::XABPRODEF$$_FILL_1) ! point to our xabpro
!
! Here is what I found in my copy of BASIC$STARLET.TLB (OpenVMS-8.4 with Alpha BASIC 1.7)
!
user_xabpro::xabprodef$$_fill_1 = xab$c_pro ! init my xabpro
user_xabpro::xabprodef$$_fill_2 = xab$c_prolen !
user_xabpro::xabprodef$$_fill_4 = 0 ! next xab links to here
!
%let %method=0% !
%if %method=0% %then ! 0=no poking (more safe)
print "-i- replacing the xab chain" !
user_fab::fab$l_xab = loc(user_xabsum::xabsumdef$$_fill_1) ! only use OUR xabsum (overwrite previous)
%else ! 1=poking (more dangerous)
print "-i- extending the xab chain" !
junk% = my_poke_L(hook2%, loc(user_xabsum::xabsumdef$$_fill_1)) ! add our stuff to end of chain
%end %if !
!
! open the file
!
print "-i- calling sys$open" !
rc% = sys$open( user_fab ) ! this system call opens the file
if (rc% and rms$_normal) then ! if the open was successful
cmn_num_keys = user_xabsum::xab$b_nok ! number of keys
!
cmn_alq = user_fab::fab$l_alq !
cmn_org = user_fab::fab$b_org !
cmn_rat = user_fab::fab$b_rat !
cmn_bks_bls = user_fab::fab$b_bks !
cmn_mrs = user_fab::fab$w_mrs !
cmn_rfm = user_fab::fab$b_rfm !
cmn_mrn = user_fab::fab$l_mrn !
!
gosub scan_xab_list ! also defines hook2% on first pass
!
print "-i- protection bits: "; user_xabpro::xab$w_pro !
!
! "I Think" the call to SYS$DISPLAY is only effective for filling in details of XABKEYDEF
! (does nothing with XABSUMDEF)
!
if (cmn_org = fab$c_idx) then !
!~~~ user_fab::fab$l_xab = loc(user_xabkey(0)) x overwrite this pointer for the 2nd time
user_xabpro::xabprodef$$_fill_4 = loc(user_xabkey(0)) ! link xabkey to xabpro
for i% = 0 to cmn_num_keys-1 !
user_xabkey(i%)::XABKEYDEF$$_FILL_1 = XAB$C_KEY !
user_xabkey(i%)::XABKEYDEF$$_FILL_2 = XAB$S_XABKEYDEF !
user_xabkey(i%)::XABKEYDEF$$_FILL_3 = 0 !
user_xabkey(i%)::XABKEYDEF$$_FILL_4 = 0 !
user_xabkey(i%)::xab$b_ref = i% ! remember key number
if i% > 0 then !
user_xabkey(i%-1)::XABKEYDEF$$_FILL_4 = loc(user_xabkey(i%)) ! take care of back linkage
end if !
next i% !
rc% = sys$display( user_fab ) !
if (rc% and 7%) <> 1% then !
print "-i- sys$display rc: "+ str$(rc%)+" ("+ str$( rc% and 7%) +")"
end if !
end if !
!
print "-i- calling sys$connect" !
rc% = sys$connect( user_rab ) ! connect to the rab
if (rc% and 7%) <> 1% then !
print "-i- sys$connect rc: "+ str$(rc%) +" ("+ str$(rc% and 7%) +")"
end if !
!
! insert code to peek at components of user_rab
! then disconnect
!
print "-i- calling sys$disconnect" !
rc% = sys$disconnect( user_rab ) ! connect to the rab
if (rc% and 7%) <> 1% then !
print "-i- sys$disconnect rc: "+ str$(rc%) +" ("+ str$(rc% and 7%) +")"
end if !
else !
print "-i- sys$open rc: "+ str$(rc%) +" ("+ str$(rc% and 7%) +")"
cmn_alq = 0 !
cmn_org = 0 !
cmn_rat = 0 !
cmn_bks_bls = 0 !
cmn_mrs = 0 !
cmn_rfm = 0 !
end if !
goto close_n_exit !
!-----------------------------------------------------------------------
! scan fabs (sub-routine)
!-----------------------------------------------------------------------
!
! note: XABs are in a linked list. We can either:
! 1) follow the existing lists looking for the one we want (might need to write a peek() function)
! 2) or switch-in our own list just for quick hacking purposes
!
scan_xab_list: !
print "-i- FAB XABs ------- pass# "+ str$(pass%) +" -------" !
p_addr = loc(user_fab::fab$l_xab) !
p_data = user_fab::fab$l_xab ! address of an xab
!
next_xab: !
if p_data = 0 then ! if end-of-list marker
hook9% = p_addr ! then remember this location
else !
print "-i- xab id code : "; my_peek_B( p_data );" "; !
select my_peek_B( p_data )
case XAB$C_ALL
print "XAB$C_ALL"
case XAB$C_CXF
print "XAB$C_CXF"
case XAB$C_CXR
print "XAB$C_CXR"
case XAB$C_DAT
print "XAB$C_DAT"
case XAB$C_FHC
print "XAB$C_FHC"
case XAB$C_ITM
print "XAB$C_ITM"
case XAB$C_JNL
print "XAB$C_JNL"
case XAB$C_KEY
print "XAB$C_KEY"
case XAB$C_PRO
print "XAB$C_PRO"
case XAB$C_RDT
print "XAB$C_RDT"
case XAB$C_RU
print "XAB$C_RU"
case XAB$C_SUM
print "XAB$C_SUM"
case XAB$C_TRM
print "XAB$C_TRM"
case else
print " ???"
end select
print "-i- xab blk len : "; my_peek_B( p_data+1) !
print "-i- xab spare : "; my_peek_W( p_data+2) !
print "-i- xab next xab : "; my_peek_L( p_data+4) ! xab$l_nxt is a long, 4 bytes from the start
p_addr = p_data+4 !
p_data = my_peek_L( p_data+4) !
goto next_xab !
end if !
if pass% = 0 then ! if first pass thru
hook2% = hook9% ! we only save on the first pass thru
print "-i- hook : "; hook2%
end if !
print "----------------------------------------"
pass% = pass% + 1 !
return !
!-----------------------------------------------------------------------
! from this point on, do not disturb rc%
!-----------------------------------------------------------------------
close_n_exit: !
%if %method=0% %then !
print "-i- restoring the xab chain" !
user_fab::fab$l_xab = preserve% ! repair chain b4 we exit
%else !
print "-i- restoring the xab chain" !
junk% = my_poke_L(hook2%, 0) ! repair chain b4 we exit
%end %if !
print "-i- calling sys$close" !
junk% = sys$close( user_fab ) ! close now cuz we'll reopen it later with a map
if (junk% and 7%) <> 1% then !
print "-e- sys$close rc: "+str$(junk%)+" ("+ str$(junk% and 7%) +")"!
end if !
print "-i- exiting my_open()"
end function rc% !
!=======================================================================
! peek L(ong)
!=======================================================================
32110 function long my_peek_L(long incomming by ref) ! long function receives long address
option type=explicit !
my_peek_L = incomming ! exit with this value
end function !
!=======================================================================
! peek W(ord)
!=======================================================================
32120 function word my_peek_W(word incomming by ref) ! word function receives word address
option type=explicit !
my_peek_W = incomming ! exit with this value
end function !
!=======================================================================
! peek B(yte)
!=======================================================================
32130 function byte my_peek_B(byte incomming by ref) ! byte function receives byte address
option type=explicit !
my_peek_B = incomming ! exit with this value
end function !
!=======================================================================
! peek Q/uadword
!=======================================================================
32140 function basic$quadword my_peek_Q(basic$quadword incomming by ref) ! byte 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 !
!=======================================================================
! my_loc
!
! This function was needed to get around a compiler restriction with Alpha-BASIC-3.7 on OpenVMS-8.4
! I'm do not know if the restriction existed with earlier Alpha BASIC compilers
!=======================================================================
32150 function long my_loc(long incomming by value) ! this function receives an address
option type=explicit !
my_loc = incomming ! exit with this value
end function !
!=======================================================================
! poke L(ong)
!=======================================================================
32160 function long my_poke_L(long incomming by ref, long poke_data by value) ! long function receives long address
option type=explicit !
declare long status% !
when error in !
incomming = poke_data !
status% = 0 !
use !
status% = err !
end when !
my_poke_L = status% ! 0 means a-okay
end function !