OpenVMS Source Code Demos
ADVOCATE_SERVER_103.BAS
1000 %TITLE "Advocate_server_xxx"
%IDENT "Version_103.1"
declare string constant k_version = "103.1"
!=========================================================================================================================
!1 2 3 4 5 6 7 8 9 0 1 2 3
!0123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890
!=========================================================================================================================
! Title : Advocate_server_xxx
! Author : Neil S. Rieck
! Purpose: Receives DCL commands from people with no privs and executes them on their behalf
!=========================================================================================================================
! History:
!
! Ver Who When What
! --- --- ------ -------------------------------------------------------------------------------------------------------
! 100 NSR 010307 1. derived from alarm_server_126.bas (written many years ago)
! 2. many changes and additions
! 101 NSR 010308 1. started adding two-way support
! 2. added a third mailbox (lck) which is only used to control client access to the tool
! 102 NSR 030807 1. started STARLET renovation
! 2. program renovation
! 103 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
!
%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
%include "$clidef" %from %library "sys$library:basic$starlet" ! cli$
!
external long ast_service_routine ! my AST service routine
declare string constant k_program = "Advocate_server"
declare string constant advocate_out$ = "csmis$tmp:advocate_outfile.txt"
!
%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)
!
declare long rc% , ! Return Code (system status) &
csa% , ! completion status address &
junk% , ! &
flags% ,! ! &
count% , ! &
response_sent% , ! &
word funct% , ! &
string junk$ , ! &
temp$ , ! &
temp2$
!+
!========================================
! Misc Declarations
!========================================
!-
map(xyz)string dcl_command_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% , ! &
chan_l% , ! &
long line_insert% , ! insert pointer (subscript) &
line_remove% , ! remove pointer (subscript) &
qio_rc% , ! &
logging_flag% , ! &
logging_flag_old% !
!+
!========================================
! 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
!
declare string constant mbx_name_lck = "CSMIS$ADVOCATE_LCK"
declare string constant mbx_name_cmd = "CSMIS$ADVOCATE_CMD"
declare string constant mbx_name_rsp = "CSMIS$ADVOCATE_RSP"
!
! 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_cmd
rc% = sys$CreMbx( 1% by value ! mbx=permanent &
,chan_recv%,,,, ! VMS will assign the channel number &
,mbx_name_cmd, ! mbx name &
) !
print "-e-sys$CreMbx-rc: ";rc% if (rc% and 7%) <> 1
print "-i-chan-r: ";str$(chan_recv%)
!
print "-i-Creating MailBox: ";mbx_name_rsp
rc% = sys$CreMbx( 1% by value ! mbx=permanent &
,chan_xmit%,,,, ! VMS will assign the channel number &
,mbx_name_rsp, ! mbx name &
) !
print "-i-sys$CreMbx-rc: ";rc% if (rc% and 7%) <> 1
print "-i-chan-x: ";str$(chan_xmit%)
!
print "-i-Creating MailBox: ";mbx_name_lck
rc% = sys$CreMbx( 1% by value ! mbx=permanent &
,chan_l%,,,, ! VMS will assign the channel number &
,mbx_name_lck, ! mbx name &
) !
print "-i-sys$CreMbx-rc: ";rc% if (rc% and 7%) <> 1
print "-i-chan-l: ";str$(chan_l%)
rc% = sys$dassgn( chan_l% by value ) ! now release this mail box
print "-i-sys$dassgn-rc: ";rc%
!
! purge mbx-read
!
print "-i-purge-mbx-r"
qio_sb_recv::rc = ss$_normal
while qio_sb_recv::rc = ss$_normal
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): ";qio_rc% if (qio_rc% and 7%) <> 1
!
select qio_sb_recv::rc
case ss$_normal
print "Discarded-r = ";left$(qio_purge$, qio_sb_recv::xfer_count )
case ss$_EndOfFile
case else
print "-e-qiow-r-rc = ";qio_sb_recv::rc
end select
next
!
! purge mbx-write (xmit)
!
print "-i-purge-mbx-x"
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): ";rc% if (rc% and 7%) <> 1
!
select qio_sb_xmit::rc
case ss$_normal
print "Discarded-x = ";left$(qio_purge$, qio_sb_xmit::xfer_count )
case ss$_EndOfFile
case else
print "-e-qiow-x-rc = ";qio_sb_xmit::rc
end select
next
!
! now raise the priority (so 'ast_service_routine' will work like an interrupt service routine)
!
! Note: consider controlling priority from batch job that starts the program
!
!~~~ print "Raising Priority to 9"
!~~~ rc% = sys$SetPri( ,,9%,)
!~~~ print "-e- rc: ";rc% if (rc% and 7%) <> 1
!
! 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): ";qio_rc% if (qio_rc% and 7%) <> 1
!
! /// do this forever ///
!
logging_flag_old% = -1%
while 1%=1%
!
! support logging verbage level
!
select edit$( WCSM_TrnLnm( "CSMIS$ADVOCATE_SERVER_VERBAGE", "LNM$SYSTEM_TABLE" ), 2%)
case "2"
logging_flag% = 2%
case "YES", "1"
logging_flag% = 1%
case else
logging_flag% = 0%
end select
!
if logging_flag% <> logging_flag_old% then
logging_flag_old% = logging_flag%
print "-i-Verbage level now at: ";str$(logging_flag%)
end if
!
while line_insert% <> line_remove% ! if we have work to do
if line_insert% <> line_remove% then !
!
! extract the data from the ring buffer
! (and place it into my alarm buffer)
!
dcl_command_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_command_line,128%+32%) ! no trailing + upcase
junk% = 0% ! default to reject
junk% = 1% if pos(junk$,"SHOW TIME" ,1%)=1%
junk% = 1% if pos(junk$,"SHOW QUEUE" ,1%)=1%
junk% = 1% if pos(junk$,"START/QUEUE" ,1%)=1%
junk% = 1% if pos(junk$,"STOP/QUEUE" ,1%)=1%
junk% = 1% if pos(junk$,"INITIALIZE/QUEUE" ,1%)=1%
junk% = 1% if pos(junk$,"DELETE/QUEUE" ,1%)=1%
junk% = 1% if pos(junk$,"PRINT/QUEUE" ,1%)=1%
!
if junk% = 0% then !
temp$ = "-e- dcl cmd rejected>"+junk$+"<"
print temp$
gosub send_response if junk$ <> ""
else
print "-i- dcl cmd>";junk$;"<"
!
! LIB$SPAWN [command-string] [,input-file] [,output-file] [,flags] [,process-name]
! [,process-id] [,completion-status-address] [,byte-integer-event-flag-num] [,AST-address]
! [,varying-AST-argument] [,prompt-string] [,cli] [,table]
!
! flags: CLI$M_NOWAIT, CLI$M_NOCLISYM, CLI$M_NOLOGNAM, CLI$M_NOKEYPAD, CLI$M_NOTIFY,
! CLI$M_NOCONTROL, CLI$M_TRUSTED, CLI$M_AUTHPRIV, and CLI$M_SUBSYSTEM.
!
flags% = CLI$M_NOCLISYM or CLI$M_NOLOGNAM or CLI$M_TRUSTED ! just fooling around
rc% = lib$spawn(junk$,,advocate_out$,flags%,,,csa%,,,,,,)
print "-i- lib$spawn:"
print " rc : "+ str$(rc%) +" -"+ mid$("wseif???",(rc% and 7%)+1%, 1%) +"-" ! return code
print " csa: "+ str$(csa%) ! completion status address
!
! this section of code is just exploring some future possibilities
!
response_sent% = 0%
when error in
!
! open the response file
!
open advocate_out$ for input as #1 &
,organization sequential &
,recordtype any
count% = 0%
!
! copy the ressponse file to the server's ".out" file
!
while 1
linput #1, temp2$ ! read a line
temp2$ = edit$(temp2$, 128) ! no trailing white space
count% = count% + 1% !
print "-i- resp-0 ";format$(count%,"###");">";temp2$;"<"
while len(temp2$)>0% !
temp$ = left$(temp2$,70%) ! slice-n-dice long lines
if len(temp$)>0 then !
gosub send_response ! send temp$
response_sent% = response_sent% + 1% !
print "-i- resp-1 ";format$(response_sent%,"###");">";temp2$
end if
junk$ = right$(temp2$,71%) ! scoop up the rest
junk$ = edit$(junk$,8) ! drop any leading white space
if len(junk$)>0 then ! if we've got something...
temp2$ = " "+ junk$ ! ...then prefix with 2 spaces (continuation)
else
temp2$ = "" ! else show us empty
end if
next
next
use
print "-e-err: ";str$(err);" while processing advocate_out$" if err<>11%
end when
print "=========="
close #1
!
when error in
while 1
kill advocate_out$ ! now delete all response files
next
use
end when
if response_sent% = 0% then ! cuz not all DCL commands have a response
temp$ = "Done"
gosub send_response
end if
end if
!
end if
!
next
!
call sys$hiber ! sleep until we receive another message
!
next
!----------------------------------------------------------------------------------------------------
! send response back to connected process
!----------------------------------------------------------------------------------------------------
send_response:
print "-i- Starting qio write"
temp$ = temp$ + cr ! cuz every line needs an EOL
qio_buffer_xmit = temp$
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 by ref ! p1 buf address &
,len( temp$ ) by value ! p2 buf length &
,,,, )
print "-e- $Qio-rc(4): ";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:
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% , ! &
chan_l% , ! &
long line_insert% , ! insert pointer (subscript) &
line_remove% , ! remove pointer (subscript) &
qio_rc% , ! &
logging_flag% , ! &
logging_flag_old% !
!
!~~~ print "ast iosb_rc: " + str$( qio_sb_r::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 <cr> 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): ";qio_rc% if (qio_rc% and 7%) <> 1
!
! BASIC Anomaly #1.b (above)
! ------------------
! The QIO system call expects to pass the address of the AST service routine my value which is not the same as by REF
!
! 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.