OpenVMS Source Code Demos

overview:

  1. the server has high privs
  2. the client has low privs
  3. 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                                  ! this QUAD must be used in the call
                    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                                  ! this QUAD must be used in the call
                    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 OpenVMS
Back to Home
Neil Rieck
Kitchener - Waterloo - Cambridge, Ontario, Canada.