OpenVMS Source Code Demos
overview:
- the server has high privs
- the client has low privs
- the client talks to the server through a memory structure known as a mail box, requesting that the server do some work on behalf of the client
Advocate_Client.bas
1000 %TITLE "Advocate_client_xxx"
%IDENT "Version_1.03"
!=========================================================================================================================
!1 2 3 4 5 6 7 8 9 0 1 2 3
!0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
!=========================================================================================================================
! Title : Advocate_client_xxx
! Author : Neil S. Rieck
! Purpose: Sends DCL commands (from people with no privs) to advocate_server which executes them on their behalf
! Notes :
!=========================================================================================================================
! History:
!
! Ver Who When What
! ---- --- ------ -------------------------------------------------------------------------------------------------------
! 1.01 NSR 010309 1. derived from advocate_server_101.bas
! 2. now non-priv users connect to mailboxes with $assign rather than $crembx
! 3. added a third mailbox (lck) which is only used to control client access to the tool
! NSR 010726 4. added a 100 try limit to the initial mailbox cleanup
! 1.02 NSR 030807 1. started STARLET renovation
! 1.03 NSR 070813 1. inlined a few functions for release to public domain
!=========================================================================================================================
! Overview:
!
! +--------+ +---------+ +--------+
! | client +-----+ MBX:lck | | server |
! | | +---------+ | |
! | | +---------+ | |
! | +---->+ MBX:cmd +---->+--->+ |
! | | +---------+ | | |
! | | +---------+ | | |
! | +<----+ MBX:rsp +<----+<---+ |
! +--------+ +---------+ +--------+
!
!=========================================================================================================================
option type = explicit ! cuz tricks are for kids
set no prompt !
!
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
%include "$iodef" %from %library "sys$library:basic$starlet" ! io$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
%include "$libdef" %from %library "sys$library:basic$starlet" ! eg. lib$_normal
!
external long ast_service_routine ! my AST service routine
!
%if %declared ( %basic$quadword_declared ) = 0 %then
record basic$quadword
long fill ( 2 )
end record
%let %basic$quadword_declared = 1
%end %if
!
! /// I/O Status Block ///
!
%if %declared (%IOSBREC) = 0 %then
record IosbRec ! structure of I/O Status Block
variant
case
group one
word rc ! return code
word xfer_count ! transfer count
long long_0 ! device specific info
end group one
case
group two
basic$quadword quad_0 ! unsigned quad word (system calls)
end group two
end variant
end record IosbRec
%let %IOSBREC = 1
%end %if
!+
!========================================
! Internal Declarations
!========================================
!-
external string function WCSM_DT_Stamp ! home brewed code
external string function WCSM_TrnLnm( string, string)
!
%include "[.inc]device_controls.inc"
declare string constant dq = '34'C ! double quote
!
declare long rc% , ! Return Code (system status) &
cs% , ! completion status &
word funct% , ! &
long junk% , ! &
debug% , ! &
count% , ! &
got_one% , ! &
got_total% , ! &
time_out_count% , ! &
try% , ! &
string junk$ , ! &
temp$ , ! &
menu_choice$ , ! &
my_cmd$ , ! &
my_que$ , ! &
my_dns$ , ! &
my_port$ , ! &
my_device$
!+
!========================================
! Misc Declarations
!========================================
!-
map(xyz)string dcl_response_line = 255%
!
! the next constant and map must be identical with the one in the AST
!
declare long constant k_ring_size = 60%
map(qio)IosbRec qio_sb_recv , ! &
qio_sb_xmit , ! &
string qio_buffer_recv = 255% , ! &
qio_buffer_xmit = 255% , ! &
line$(k_ring_size) = 255% , ! ring buffer &
word chan_recv% , ! &
chan_xmit% , ! &
long line_insert% , ! insert pointer (subscript) &
line_remove% , ! remove pointer (subscript) &
qio_rc% !
!+
!========================================
! Main
!========================================
!-
2000 on error goto trap
margin #0, 132%
!
declare string constant mbx_name_cmd = "CSMIS$ADVOCATE_CMD" !
declare string constant mbx_name_rsp = "CSMIS$ADVOCATE_RSP" !
declare string constant mbx_name_lck = "CSMIS$ADVOCATE_LCK" !
!
print
print "-i- allocating device: "; mbx_name_lck
rc% = sys$alloc( mbx_name_lck,,,,) !
junk% = rc% and 7% ! keep lower 3 bits
select junk%
case 1% ! normal
case else
select rc%
case 324% ! no such mailbox
print "-"; mid$("wseif???",junk%+1%,1%);"- alloc-rc: ";rc%
print "-i- MAILBOX not found, start the ADVOCATE server and try again"
goto fini
case else
print "-"; mid$("wseif???",junk%+1%,1%);"- alloc-rc: ";rc%
print "-i- the tool is locked by someone else, please try again later"
goto fini
end select
end select
!
%let %non_priv_user=1% !
%if %non_priv_user=1% %then ! support non-priv users
rc% = sys$assign( mbx_name_rsp, chan_recv%,,) !
print "-i- sys$assign-rc: ";rc% !
%else ! support only priv users
! create the permanent mailbox (if it already exists, a new one won't be created but a channel will be opened to it)
print "-i- Creating MailBox: ";mbx_name_rsp ! this is 'cmd' in server
rc% = sys$CreMbx( 1% by value ! mbx=permanent &
,chan_recv%,,,, ! VMS will assign the channel number &
,mbx_name_rsp, ! mbx name &
) !
print "-i- sys$CreMbx-rc: ";rc% !
%end %if !
print "-i- chan-recv: ";str$(chan_recv%) !
!
%if %non_priv_user=1% %then ! support non-priv users
rc% = sys$assign( mbx_name_cmd, chan_xmit%,,) !
print "-i-sys$assign-rc: ";rc% !
%else ! support only priv users
print "-i-Creating MailBox: ";mbx_name_cmd ! this is 'rsp' in server
rc% = sys$CreMbx( 1% by value ! mbx=permanent &
,chan_xmit%,,,, ! VMS will assign the channel number &
,mbx_name_cmd, ! mbx name &
) !
print "-i-sys$CreMbx-rc: ";rc% !
print "-i-chan-xmit: ";str$(chan_xmit%) !
%end %if
!
! purge mbx-read
!
print "-i-purge-mbx-recv"
try% = 0%
qio_sb_recv::rc = ss$_normal
while qio_sb_recv::rc = ss$_normal
try% = try% + 1%
map (QioPurge) string qio_purge$=80
qio_rc% = sys$qiow( ,chan_recv% by value &
,(io$_readvblk or io$m_now) by value &
,qio_sb_recv::quad_0 by ref &
,, &
,qio_purge$ by ref &
,len( qio_purge$ ) by value &
,,,, )
print "-e- $qio-rc(1): ";str$(qio_rc%) if (qio_rc% and 7%) <> 1
!
select qio_sb_recv::rc
case ss$_normal
print "Discarded-recv = ";left$(qio_purge$, qio_sb_recv::xfer_count )
if try% >= 100% then
print "Discarded-xmit- Mailbox not emptied in 100 trys, the server may be down"
goto fini
end if
case ss$_EndOfFile
case else
print "-e-qiow-recv-rc = ";qio_sb_recv::rc
end select
next
!
! purge mbx-xmit
!
print "-i-purge-mbx-xmit"
qio_sb_xmit::rc = ss$_normal
while qio_sb_xmit::rc = ss$_normal
qio_rc% = sys$qiow( ,chan_xmit% by value &
,(io$_readvblk or io$m_now) by value &
,qio_sb_xmit::quad_0 by ref &
,, &
,qio_purge$ by ref &
,len( qio_purge$ ) by value &
,,,, )
print "-e- $qio-rc(2): ";str$(qio_rc%) if (qio_rc% and 7%) <> 1
!
select qio_sb_xmit::rc
case ss$_normal
print "Discarded-xmit = ";left$(qio_purge$, qio_sb_xmit::xfer_count )
case ss$_EndOfFile
case else
print "-e-qiow-xmit-rc = ";qio_sb_xmit::rc
end select
next
!
! do the first qio READ to start things off
!
! SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6]
!
print "-i-Starting 1st qio"
qio_rc% = sys$Qio( ! event flag &
,chan_recv% by value ! channel &
,io$_readvblk by value ! function &
,qio_sb_recv::quad_0 by ref ! i/o status &
,ast_service_routine by ref ! ast address &
, ! ast parameter &
,qio_buffer_recv by ref ! p1 buf address &
,len( qio_buffer_recv ) by value ! p2 buf length &
,,,, )
print "-e- $qio-rc(3): ";str$(qio_rc%) if (qio_rc% and 7%) <> 1
!
debug% = 0%
print vt$clear + vt$home;
while 1
print "============================"
print " ICSIS tcp print-queue tool"
print "============================"
my_que$ = "ICSIS$SPOOL_TOOL"
print " 1. show queue: "; my_que$
print " 2. conf queue: "; my_que$
print " 3. start queue: "; my_que$
print " 4. stop queue: "; my_que$
print " 5. delete queue: "; my_que$
print " 8. print 59x80 to: "; my_que$
print " 9. quit"
print " ?. help/notes"
print "choice> ";
input menu_choice$
menu_choice$ = edit$(menu_choice$, 32%+2%)
select menu_choice$
case "1"
my_cmd$ = "SHOW QUEUE/ALL/FULL "+ my_que$
gosub send_n_receive
case "2"
print "enter 'full dns name' or 'i/p' > ";
input my_dns$
my_dns$ = edit$(my_dns$, 2%)
iterate if my_dns$ = ""
!
print "enter tcp port (eg. HP/LJ=9100) > ";
input my_port$
my_port$ = edit$(my_port$, 2%)
iterate if my_port$ = ""
!
my_cmd$ = "STOP/QUEUE/RESET "+ my_que$
gosub send_n_receive
!
my_cmd$ = "DELETE/QUEUE "+ my_que$
gosub send_n_receive
!
my_device$ = my_dns$ +","+ my_port$
my_cmd$ = "INITIALIZE/QUEUE/START/RETAIN=ERROR/DEFAULT=(NOFLAG,FEED,FORM=DEFAULT,NOTRAIL)"
my_cmd$ = my_cmd$ + "/PROCESSOR=TCPWARE_TSSYM/ON="+ dq + my_device$ +",KEEP"+ dq +"/LIBRARY=SYSDEVCTL"
my_cmd$ = my_cmd$ + "/SEPARATE=RESET=(PRT_BLANK_LINE)/DEFAULT=(FORM=NEIL88) "+ my_que$
gosub send_n_receive
case "3"
my_cmd$ = "START/QUEUE "+ my_que$
gosub send_n_receive
case "4"
my_cmd$ = "STOP/QUEUE/RESET "+ my_que$
gosub send_n_receive
case "5"
my_cmd$ = "DELETE/QUEUE "+ my_que$
gosub send_n_receive
case "6"
case "7"
case "8"
my_cmd$ = "PRINT/QUEUE="+ my_que$ +" csmis$com:TEST_59X80.TXT"
gosub send_n_receive
case "99"
my_cmd$ = "SHOW TIME"
gosub send_n_receive
case "9","Q","E",""
goto fini
case "?","H"
! 123456789012345678901234567890123456789012345678901234567890123456789012345678
print "help:"
print "1. this print queue is not available from any ICSIS application. Use command"
print " 8 to send a test page"
print "2. this print queue is not permanent (parameters may be changed by the next"
print " person running this tool"
print "3. this program can't change line parameters of far end devices (like flow"
print " control settings of Synoptics-3395 or DS200 terminal servers since they"
print " have usually been password protected by other groups)"
print "4. some printers have been known not to work properly on the very first"
print " document sent just after a queue is defined. This means that you may need"
print " to print twice before you see your first document."
case "D"
select debug%
case 0%
debug% = 1%
print "-i- Debug: ON"
case else
debug% = 0%
print "-i- Debug: OFF"
end select
end select
next
!----------------------------------------------------------------------------------------------------
! send and receive
!----------------------------------------------------------------------------------------------------
send_n_receive:
print " ===== transaction start ====="
line_insert% = line_remove% ! turf anything in the receive buffer
gosub send_to_server ! send command to server
!
got_one% = 0%
got_total% = 0%
time_out_count% = 0%
!
while 1%=1%
!
while line_insert% <> line_remove% ! if we have work to do...
!
got_total% = got_total% + 1% ! tally for early exit logic
time_out_count% = 0% ! reset
!
! extract the data from the ring buffer
!
dcl_response_line = edit$( line$( line_remove% ), 128%+4% )
!
! advance the remove pointer NOW
!
select line_remove%
case < k_ring_size
line_remove% = line_remove% + 1%
case else
line_remove% = 0%
end select
!
! process the extracted string
!
junk$ = edit$( dcl_response_line, 128% ) ! no trailing
print "resp>";junk$
!
next
!
if got_total% = 0% then ! if nothing yet received...
goto recv_exit if time_out_count% >= 7% ! 14 seconds
print "-i- waiting for response" if time_out_count% >= 3% ! 6 seconds
sleep 2
time_out_count% = time_out_count% + 1%
else ! if something already received...
goto recv_exit if time_out_count% >= 2% ! 2 seconds
sleep 1
time_out_count% = time_out_count% + 1%
end if
next
recv_exit:
print bel,"-e- timeout, no response from server" if got_total% = 0%
print " ===== transaction finish ====="
return
!----------------------------------------------------------------------------------------------------
! send response back to connected process
!----------------------------------------------------------------------------------------------------
send_to_server:
print "-i-Starting qio write" if debug% > 0%
print "send>$";my_cmd$
my_cmd$ = my_cmd$ + cr
qio_buffer_xmit = my_cmd$
funct% = io$_writevblk or io$m_now or io$m_norswait
qio_rc% = sys$Qio( ! event flag &
,chan_xmit% by value ! channel &
,funct% by value ! function &
,qio_sb_xmit::quad_0 by ref ! i/o status &
, ! ast address &
, ! ast parameter &
,qio_buffer_xmit ! p1 buf address &
,len( my_cmd$ ) by value ! p2 buf length &
,,,, )
print "-e- $qio-rc(4): ";str$(qio_rc%) if (qio_rc% and 7%) <> 1
return
!
!========================================
! 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% = sys$dalloc( mbx_name_lck,) ! de-allocate
print ""
print "enter MENU to re-run the ICSIS menu"
32000 end !
!
!########################################################################################################################
!
!===============================================================================================================
! <<< ast_service_routine >>>
!
! param%: user defined parameter
! gpr_0%: general purpose register 0
! gpr_1%: general purpose register 1
! pc% : program counter
! pcl% : program status long word
!
! Note : this routine works like an interrupt service routine so it should do as little processing as possible
!===============================================================================================================
32100 sub ast_service_routine by ref (LONG param%, gpr_0%, gpr_1%, pc%, psl%)
!
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 "$iodef" %from %library "sys$library:basic$starlet" ! io$
%include "lib$routines" %from %library "sys$library:basic$starlet" ! lib$
%include "$libdef" %from %library "sys$library:basic$starlet" ! eg. lib$_normal
external long ast_service_routine ! my AST service routine
!
%if %declared ( %basic$quadword_declared ) = 0 %then
record basic$quadword
long fill ( 2 )
end record
%let %basic$quadword_declared = 1
%end %if
!
! /// I/O Status Block ///
!
%if %declared (%IOSBREC) = 0 %then
record IosbRec ! structure of I/O Status Block
variant
case
group one
word rc ! return code
word xfer_count ! transfer count
long long_0 ! device specific info
end group one
case
group two
basic$quadword quad_0 ! unsigned quad word (system calls)
end group two
end variant
end record IosbRec
%let %IOSBREC = 1
%end %if
!
! the next constant and map must be identical with the one in MAIN
!
declare long constant k_ring_size = 60%
map(qio)IosbRec qio_sb_recv , ! &
qio_sb_xmit , ! &
string qio_buffer_recv = 255% , ! &
qio_buffer_xmit = 255% , ! &
line$(k_ring_size) = 255% , ! ring buffer &
word chan_recv% , ! &
chan_xmit% , ! &
long line_insert% , ! insert pointer (subscript) &
line_remove% , ! remove pointer (subscript) &
qio_rc% !
!
!~~~ print "ast iosb_rc: " + str$( qio_sb_recv::rc) + " iosb_bc: " + str$( qio_sb_recv::xfer_count )
!
! erase old mapped string
! then copy over received data
!
line$( line_insert% ) = "" ! zap old text
line$( line_insert% ) = left$( qio_buffer_recv, integer(qio_sb_recv::xfer_count) )
!
! Anomaly #3:
! There is a in the middle of this mapped string so remove it before printing (or the trailing blanks will
! overwrite your text and make it disappear)
!
!~~~ print "ast buf: "+ edit$( line$( line_insert% ), 128%+4%)
!
! move the insertion pointer (main will try to catch up by advancing the removal pointer)
!
select line_insert%
case < k_ring_size
line_insert% = line_insert% + 1%
case else
line_insert% = 0%
end select
!
! SYS$QIO [efn] ,chan ,func ,[iosb] ,[astadr] ,[astprm] ,[p1] ,[p2] ,[p3] ,[p4] ,[p5] ,[p6]
!
qio_rc% = sys$Qio( ! event flag &
,chan_recv% by value ! channel &
,io$_readvblk by value ! function &
,qio_sb_recv::quad_0 by ref ! i/o status &
,ast_service_routine by ref ! ast address &
, ! ast parameter &
,qio_buffer_recv by ref ! p1 buf address &
,len( qio_buffer_recv ) by value ! p2 buf length &
,,,, )
print "-e- $qio-rc(5): ";str$(qio_rc%) if (qio_rc% and 7%) <> 1
!
! the upper half of this program may be hybernating so wake it up
!
call sys$wake(,) ! wake up main
!
subend ! that's all
!========================================================================================================================
!
32200 function string WCSM_TrnLnm ( string logical_name$, table_name$ )
!========================================================================================================================
! Title : wcsm_trnlnm.fun
! Author : Neil S. Rieck
! Purpose: an external function to translate logical names
! Notes : 1. all our programs call this function so optimizations here will speed up the whole system
! : 2. use LIB$TRNLNM if speed isn't important
! History:
! 100 NSR 910911 1. original work
! NSR 940420 2. changed mapsize from 31 to 255
! NSR 000208 3. modified for use with 'starlet'
! NSR 021019 4. optimizations
! NSR 040516 5. now only do SUPERVISOR mode translations bf_100.5
! NSR 040519 6. returned this program to its previous functionality
!========================================================================================================================
! Notes :
!
! 1. please include the next line near the top of your source program (after 'option type=explicit')
!
! external string function WCSM_TrnLnm (string, string)
!
! 2. please include the next 2 lines near the bottom of of your source program (after 'END' of the main module)
!
! %include "[.fun]wcsm_trnlnm.fun"
!! ! function string WCSM_TrnLnm ( logical_name$, table_name$ )
!
!========================================================================================================================
option type=explicit ! cuz tricks are for kids...
!
!~~~ %include "[.inc]vms_externals.inc" x calls many modules from starlet
%include "starlet" %from %library "sys$library:basic$starlet" ! system services
%include "$ssdef" %from %library "sys$library:basic$starlet" ! ss$
%include "$lnmdef" %from %library "sys$library:basic$starlet" ! lnm$
%include "$psldef" %from %library "sys$library:basic$starlet" ! psl$
%include "[.inc]vms_structures.inc" ! IosbRec etc.
!
declare long constant MapSize% = 255
!
! <<< declare variables >>>
!
map(WCSM_TrnLnm)string Equiv_Name$ = MapSize%
declare long sys_status , ! for return codes &
bytes_returned% , ! for system calls &
my_attributes% , ! '' &
string temp$ , ! &
byte access_mode% !
!
declare ItemRec LogLst(2) ! 3 items (0-2)
!
!==================================================
! clean up data (before table fill)
!==================================================
!
logical_name$ = edit$(logical_name$, 32+4+2)
table_name$ = edit$(table_name$, 32+4+2)
!~~~ access_mode% = PSL$C_SUPER x bf_100.5
!
!==================================================
! prep for call (fill in table)
!==================================================
!
my_attributes% = LNM$M_TERMINAL
!
LogLst(0%)::BuffLen = 4% ! 4 bytes=long
LogLst(0%)::ItemCode = lnm$_Attributes ! desired code
LogLst(0%)::BuffAddr = loc(my_attributes%) !
LogLst(0%)::RtnLenAdr = 0% ! don't care
!
LogLst(1%)::BuffLen = MapSize% ! from map statement
LogLst(1%)::ItemCode = lnm$_String ! desired code
LogLst(1%)::BuffAddr = loc(Equiv_Name$) ! address of string variable
LogLst(1%)::RtnLenAdr = loc(Bytes_Returned%) ! address of length variable
!
LogLst(2%)::List_Terminator = 0% ! end of list
!
! this is it folks, the big Kahoona...
!
sys_status = sys$trnlnm( , ! attributes &
table_name$ , ! &
logical_name$ , ! &
, ! bf_105.6 &
LogLst() ) !
!
select sys_status
case ss$_nolognam
temp$ = "" ! make sure this is clear
case ss$_normal
temp$ = left$(Equiv_Name$, bytes_returned%)
case else ! paranoia, should never happen
temp$ = "-e-SYSERR_" + str$(sys_status) !
print temp$ + bel + " In 'WCSM_TrnLnm'" !
sleep 2% !
end select
!
! copy data back to function and return to caller
!
WCSM_TrnLnm = temp$
!
end function
!
32300 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)
!===================================================================================================================
! Usage:
!
! 1. please include the next line near the top of your source
! program (after 'option type=explicit' )
!
! external string function Wcsm_DT_Stamp (string, long)
!
! 2. please include the next 2 lines near the bottom of of your
! source program (after 'END' of the main module)
!
! %include "[.fun]wcsm_dt_stamp.fun"
!! ! function string Wcsm_DT_Stamp
!===================================================================================================================
option type=explicit ! cuz tricks are for kids...
!
external long function sys$asctim
!
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
!========================================================================================================================
Back
to HomeNeil Rieck
Waterloo, Ontario, Canada.