OpenVMS Source Code Demos
DECNET_TASK_S.BAS
1000 %title "decnet_task_s_xxx"
%ident "Version_101.1" ! <<<---+---
declare string constant k_version = "101.1" , ! <<<---+ &
k_program = "DECnet Task Demo (Server)" !
!=========================================================================================================================
! Title : decnet_task_c_xxx (server)
! Author : Neil S. Rieck
! Purpose: Starts a similar server task on a remote node
! Caveat : This is a quick hack for demo purposes only. (for my buddies on comp.os.vms)
!=========================================================================================================================
! History:
!
! Ver Who When What
! --- --- ------ -------------------------------------------------------------------------------------------------------
! 100 NSR 110924 1. original program (using RMS calls like sys$open, sys$read, sys$write)
! 101 NSR 110925 1. now bypass RMS (using calls like sys$assign and sys$qio)
!=========================================================================================================================
OPTION type = explicit ! cuz tricks are for kids
!
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
%include "$libdef" %from %library "sys$library:basic$starlet" ! lib$_normal
%include "$iodef" %from %library "sys$library:basic$starlet" ! io$
!
%if %declared (%IOSBREC) = 0 %then
record IosbRec ! structure of I/O Status Block
variant
case
group one ! this variation is used with I/O transfers
word rc ! return code
word xfer_count ! transfer count
long long_0 ! device specific info
end group one
case
group two ! this variation is used to satisfy the compiler
basic$quadword quad_0 ! unsigned quad (system calls)
end group two
case
group three ! this variation is used in $SNDJBC + $SNDJBCW
long job_status ! job status
long long_3 ! device specific info
end group three
end variant
end record IosbRec
%let %IOSBREC = 1
%end %if
!
external long function get_timer_bit_vector(long) ! required for used with SYS$WFLOR
external string function wcsm_dt_stamp ! returns current time: ccyymmddhhmmss
!
!=======================================================================
! Internal Declarations
!=======================================================================
declare long rc% , ! Return Code (system status) &
junk% , ! &
count_r% , ! &
count_w% , ! &
qio_ef% , ! event flag(s) &
timer_ef% , ! &
timer_ef_state% , ! &
qio_ef_state% , ! &
mask% , ! &
word funct% , ! &
io_chan% , ! &
funct_bits_xmit , ! &
funct_bits_recv , ! &
string junk$ , ! &
yada$ , ! &
my_file$ , ! &
IosbRec iosb_xmit , ! &
IosbRec iosb_recv , ! &
basic$quadword DeltaQuad !
declare word constant b256_size = 256 !
map(b256) string b256$ = b256_size !
!=======================================================================
! Main
!=======================================================================
2000 on error goto trap !
margin #0, 132 !
print k_program +"_"+ k_version !
print string$(len(k_program +"_"+ k_version), asc("=")) ! underline previous line
!
my_file$ = "sys$net" !
!
rc% = sys$assign( my_file$, io_chan%,,) ! assign an i/o channel
if (rc% and 7%) <> 1% then
print "-e- sys$assign: "+str$(rc%)
goto fini_rc
end if
!
rc% = lib$get_EF(qio_ef%) ! get an event flag
if (rc% and 7%) <> 1% then
print "-e- lib$get_ef (1): "+str$(rc%)
goto fini_rc
end if
!
rc% = lib$get_EF(timer_ef%) ! get an event flag
if (rc% and 7%) <> 1% then
print "-e- lib$get_ef (1): "+str$(rc%)
goto fini_rc
end if
!
!-----------------------------------------------------------------------
! receive something
!-----------------------------------------------------------------------
restart_loop:
!
count_r% = 1 !
recv_loop: !
!
!
! <<< receive data >>>
!
! SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6]
!
funct_bits_recv = IO$_READVBLK
!
print "-i- calling sys$qio (read)"
rc% = sys$qio( qio_ef% by value, ! efn &
io_chan% by value, ! chan &
funct_bits_recv by value, ! func &
iosb_recv::quad_0 by ref, ! iosb &
, ! ast addr &
, ! ast param &
b256$ by ref, ! p1=buf addr &
b256_size by value, ! p2=buf size &
, ! p3=ignored &
, ! p4=cr spec &
, ! p5=N/A &
) ! p6=N/A
!
if (rc% and 7%) <> 1% then !
print "-e- sys$qio rc: ";str$(rc%) !
goto fini_rc ! adios...
else !
print "-i- sys$qio rc: ";str$(rc%) !
end if !
!
! since we didn't use $QIOW (on purpose), arm timer then wait for the one of the event flags
!
rc% = sys$bintim("0 00:00:59", DeltaQuad ) ! init delta time (59 Secs from now)
print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
rc% = sys$setimr(timer_ef%, DeltaQuad by ref,,,) ! now use it to schedule a wake up
print "-e- sys$setimr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
! The first parameter is only used to determine which event flag cluster to test.
! The second parameter (mask) contains bits representing event flags within that cluster
!
mask% = get_timer_bit_vector( qio_ef%) ! insert vector 1 into mask
mask% = mask% or get_timer_bit_vector(timer_ef%) ! insert vector 2 into mask
!
! <<< wait for either the 'QIO event flag' or the 'TIMER event flag' to change state >>>
!
junk$ = wcsm_dt_stamp ! get snap shot of current time
print "-i- waiting for flag ";qio_ef%;" or flag ";timer_ef%;" time: ";left$(junk$,8)+"."+right$(junk$,9)
!
rc% = sys$wflor( qio_ef%, mask%) ! wait for a response from one of two flags
print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
junk$ = wcsm_dt_stamp ! get snap shot of current time
print "-i- waking from event some flag at time: ";left$(junk$,8)+"."+right$(junk$,9)
!
! <<< cancel all timer requests (if any) >>>
!
print "-i- Calling $CanTim" !
rc% = sys$cantim(,) ! cancel all timer requests
print "-e- sys$cantim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
! which event flag is set? QIO or TIMER?
!
rc% = sys$readEF(qio_ef%, junk%) ! test QIO event flag
select rc% !
case SS$_WASCLR !
qio_ef_state% = 0 !
case SS$_WASSET !
qio_ef_state% = 1 !
case else !
print "-e- sys$readef-qio rc: "+ str$(rc%) !
end select !
print "-i- QIO EF State: ";str$(qio_ef_state%);" "; ! first line half (no <cr>)
!
rc% = sys$readEF(timer_ef%, junk%) ! test TIMER event flag
select rc%
case SS$_WASCLR
timer_ef_state% = 0
case SS$_WASSET
timer_ef_state% = 1
case else
print "-e- sys$readef-timer rc: "+ str$(rc%)
end select
print "-i- Timer EF State: ";str$(timer_ef_state%) ! second line half
!
! at this point either the QIO-EF or the TIMER-EF could be set
!
if (timer_ef_state% = 1) and ! if the TIMER-EF expired &
( qio_ef_state% = 0) ! and the QIO-EF didn't...
then ! then the I/O didn't finish
print "-w- oops, the qio seems hung" !
junk% = sys$cancel(io_chan%) !
print "-w- time for death"
goto fini
else ! we've got data so fall thru
if (iosb_recv::rc and 7%) <> 1 then !
print "-e- the qio failed with status code: "+ str$(iosb_recv::rc) +" ("+ str$(iosb_recv::rc and 7%) +")"
print "-w- time for death" !
rc% = iosb_recv::rc !
goto fini_rc !
else !
print "-i- the qio completed properly" !
yada$ = left$(b256$, iosb_recv::xfer_count) !
print "-i- RECV> "+ yada$
end if !
end if !
!-----------------------------------------------------------------------
! send something
!-----------------------------------------------------------------------
yada$ = "ECHO: "+ yada$ !
b256$ = yada$ !
!
! <<< xmit data >>>
!
! SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6]
!
funct_bits_xmit = IO$_WRITEVBLK
!
print "-i- calling sys$qio (write)"
rc% = sys$qio( qio_ef% by value, ! efn &
io_chan% by value, ! chan &
funct_bits_xmit by value, ! func &
iosb_xmit::quad_0 by ref, ! iosb &
, ! ast addr &
, ! ast param &
b256$ by ref, ! p1=buf addr &
len(yada$) by value, ! p2=buf size &
, ! p3=ignored &
, ! p4=cr spec &
, ! p5=N/A &
) ! p6=N/A
!
if (rc% and 7%) <> 1% then !
print "-e- sys$qio rc: ";str$(rc%) !
goto fini_rc ! adios...
else !
print "-i- sys$qio rc: ";str$(rc%) !
end if !
!
! since we didn't use $QIOW (on purpose), arm timer then wait for the one of the event flags
!
rc% = sys$bintim("0 00:00:10", DeltaQuad ) ! init delta time (10 seconds from now)
print "-e- sys$bintim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
rc% = sys$setimr(timer_ef%, DeltaQuad by ref,,,) ! now use it to schedule a wake up
print "-e- sys$setimr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
! note: for the SYS$WFLOR call to work, both event flags must be in the same event flag cluster.
! The first parameter is only used to determine which event flag cluster to test.
! The second parameter (mask) contains bits representing event flags within that cluster
!
mask% = get_timer_bit_vector( qio_ef%) ! insert vector 1 into mask
mask% = mask% or get_timer_bit_vector(timer_ef%) ! insert vector 2 into mask
!
! <<< wait for either the 'QIO event flag' or the 'TIMER event flag' to change state >>>
!
junk$ = wcsm_dt_stamp ! get snap shot of current time
print "-i- waiting for flag ";qio_ef%;" or flag ";timer_ef%;" time: ";left$(junk$,8)+"."+right$(junk$,9)
!
rc% = sys$wflor( qio_ef%, mask%) ! wait for a response from one of two flags
print "-e- sys$waitfr rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
junk$ = wcsm_dt_stamp ! get snap shot of current time
print "-i- waking from event some flag at time: ";left$(junk$,8)+"."+right$(junk$,9)
!
! <<< cancel all timer requests (if any) >>>
!
print "-i- Calling $CanTim" !
rc% = sys$cantim(,) ! cancel all timer requests
print "-e- sys$cantim rc: "+ str$(rc%) if ((rc% and 1%) <> 1%) !
!
! which event flag is set? QIO or TIMER?
!
rc% = sys$readEF(qio_ef%, junk%) ! test QIO event flag
select rc% !
case SS$_WASCLR !
qio_ef_state% = 0 !
case SS$_WASSET !
qio_ef_state% = 1 !
case else !
print "-e- sys$readef-qio rc: "+ str$(rc%) !
end select !
print "-i- QIO EF State: ";str$(qio_ef_state%);" "; ! first line half (no <cr>)
!
rc% = sys$readEF(timer_ef%, junk%) ! test TIMER event flag
select rc%
case SS$_WASCLR
timer_ef_state% = 0
case SS$_WASSET
timer_ef_state% = 1
case else
print "-e- sys$readef-timer rc: "+ str$(rc%)
end select
print "-i- Timer EF State: ";str$(timer_ef_state%) ! second line half
!
! at this point either the QIO-EF or the TIMER-EF could be set
!
if (timer_ef_state% = 1) and ! if the TIMER-EF expired &
( qio_ef_state% = 0) ! and the QIO-EF didn't...
then ! then the I/O didn't finish
print "-w- oops, the qio seems hung" !
junk% = sys$cancel(io_chan%) !
junk% = sys$cancel(io_chan%) !
print "-w- time for death"
goto fini
else ! we've got data so fall thru
if (iosb_xmit::rc and 7%) <> 1 then !
print "-e- the qio failed with status code: "+ str$(iosb_xmit::rc) +" ("+ str$(iosb_xmit::rc and 7%) +")"
print "-w- time for death" !
rc% = iosb_recv::rc !
goto fini_rc !
else !
print "-i- the qio completed properly" !
end if !
end if !
!
print "--------------------------------"
goto restart_loop
!
!=======================================================================
! Trap (BASIC error handler)
!
! this will go to sys$output (sys$error)
!=======================================================================
20000 trap:
print cr + lf + "Line = "+ str$(erl) + &
cr + lf + "Error= "+ str$(err) + &
cr + lf + "Text = "+ ert$(err)
resume fini ! fix stack + exit
!=======================================================================
! adios
!=======================================================================
Fini:
rc% = 1 ! VMS-S-
goto final_exit
!
! rc% must be set up b4 this point
!
fini_rc:
!
final_exit:
print "-i- exiting with code: "+ str$(rc%)
32000 END program rc% !
!
!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$
!
! inline external functions and sub programs
!
!======================================================================
! get timer bit vector
! (see OpenVMS system systevices documentation for "sys$wflor")
!
! notes: cluster event flags
! 0 00- 31
! 1 32- 63
! 2 64- 95
! 3 96-127
!======================================================================
32100 function long get_timer_bit_vector(long event_flag)
option type = explicit
declare long temp
!
select event_flag
case <= 31
temp = event_flag
case <= 63
temp = event_flag - 32
case <= 95
temp = event_flag - 64
case else
temp = event_flag -96
end select
!
select temp ! this code will avoid an integer overflow
case 31 ! need to set bit #31
! 33222222222211111111110000000000
! 10987654321098765432109876543210
get_timer_bit_vector = B"10000000000000000000000000000000"L ! so return this
case else !
get_timer_bit_vector = (2% ^ temp) ! else return this
end select
!
end function ! get_timer_bit_vector
!
32110 function string Wcsm_DT_Stamp
!===================================================================================================================
! Title : Wcsm_DT_Stamp_100?.inc
! Author : Neil S. Rieck
! Purpose: an external function to return a y2k compliant system time in the form ccyymmddhhmmss (14 chars)
! Notes : all our programs call this function so optimizations here will speed up the whole system
! History:
! 100a NSR 911229 1. original work
! NSR 940423 2. changed 'ON ERROR' to 'WHEN ERROR'
! 100b NSR 961108 1. cleaned up
! 100c NSR 961108 1. optimized
! 100d NSR ?????? 1. optimized
! 100e NSR 980618 1. optimized
! 2. added XX to month names so adding a skew wouldn't be necessary
! 3. replaced left hand mid$ with tens mapping
! 100f NSR 980619 1. optimized
! 2. added some code so I could remove the call to RSET (this may increase the size of both $PDATA
! and $CODE but might reduce execution time by avoiding one call to the BASIC RTL. Only
! benchmarking will determine wether this change is better or worse)
! NSR 101007 3. now use definitions from starlet
! 4. renamed the maps just incase
!===================================================================================================================
option type=explicit ! cuz tricks are for kids...
!
%include "starlet" %from %library "sys$library:basic$starlet" !
!
declare long sys_status
!
! this map is required for the call to sys$asctim (format: 19-JUN-1998 23:59:59.1)
!
map (WcsmDTStamp0) string Sys_buf_22 = 22
map (WcsmDTStamp0) string Sys_day = 2, ! &
Sys_dash1 = 1, !- &
Sys_month = 3, ! &
Sys_dash2 = 1, !- &
Sys_year = 4, ! &
Sys_space = 1, ! &
Sys_Hour = 2, ! &
Sys_colon1 = 1, !: &
Sys_Minute = 2, ! &
Sys_colon2 = 1, !: &
Sys_Second = 2, ! &
Sys_period = 1, !. &
Sys_Tenth = 1 !
!
! map for Wcsm date (output)
!
map (WcsmDTStamp1) string Wcsm_buf_14 = 14 !
map (WcsmDTStamp1) string Wcsm_year = 4, ! &
Wcsm_month = 2, ! &
Wcsm_day = 2, ! &
Wcsm_Hour = 2, ! &
Wcsm_Minute = 2, ! &
Wcsm_Second = 2
map (WcsmDTStamp1) string Wcsm_year = 4, ! &
Wcsm_month_tens = 1, ! &
Wcsm_month_ones = 1, ! &
Wcsm_day_tens = 1, ! &
Wcsm_day_ones = 1, ! &
Wcsm_Hour = 2, ! &
Wcsm_Minute = 2, ! &
Wcsm_Second = 2
!
! string constants
! 00000000011111111112222222222333333333
! 12345678901234567890123456789012345678
declare string constant k_month_names$ = "XXJANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC"
! ||
! ++-- so I don't have to provide an offset in pos()
declare string constant my_space = '32'C
!
! <<< function 'code' starts here >>>
!
when error in
!
sys_status = sys$asctim(,Sys_buf_22,,) ! get ASCII time into sys_buf_22
!~~~ if (sys_status and 7%) <> 1% then cause error 11 x not required - call will never fail
!
! transfer data from one map to the other
!
Wcsm_year = Sys_year !
!~~~ rset Wcsm_month = str$( pos(k_month_names$,Sys_Month,1%) / 3%) x bf_100f
Wcsm_day = Sys_day !
Wcsm_hour = Sys_hour !
Wcsm_minute = Sys_minute !
Wcsm_second = Sys_second !
!
declare long temp% ! bf_100f
temp% = pos(k_month_names$,Sys_Month,1%) / 3% ! compute month number bf_100f
if temp% < 10% then ! if less than 10... bf_100f
Wcsm_month_ones = str$(temp%) ! ...then this goes into ONES bf_100f
Wcsm_month_tens = "0" ! ...and this goes into TENS bf_100f
else ! else >= 10 bf_100f
Wcsm_month = str$(temp%) ! bf_100f
end if
!
! make sure there are no spaces in the TENS area of our mapped variables (pad with '0' if necessary)
!
!~~~ Wcsm_month_tens = "0" if Wcsm_month_tens = my_space x disabled - see above code bf_100f
Wcsm_day_tens = "0" if Wcsm_day_tens = my_space !
!
! now pass result back to caller
!
Wcsm_DT_Stamp = Wcsm_Buf_14 ! this is it folks
use
Wcsm_DT_Stamp = "" ! error so return blank
end when
!
END Function