From: Didier Morandi [Didier.Morandi@gmx.fr]
Sent: Thursday, February 14, 2002 4:50 PM
To: Info-VAX@Mvb.Saic.Com
Subject: DCL Minute of the St Valentine's Day: DCL_ANALYST

$!+
$! DCL_ANALYST.COM
$!
$! Builds statistics on OPEN, CLOSE, READ etc and variable assignments and
$! substitution. Also does simple checking on unclosed single or double quotes.
$!
$! <input>
$! DCL procedure name to be analysed.
$!
$! <output>
$! Display statistics on user terminal or in a resulting file.
$! (see help at the end of this procedure)
$!
$! <side effects>
$! Creates a work file in the same location as the  analysed  file,  named
$! 'filename'.WORK (this file is actually preprocessed by DCL_DIET first).
$!
$! NOTE: DCL_DIET is (c) 1998 Charlie HAMMOND, COMPAQ Computer Corporation
$!       and is available from the COMPAQ OpenVMS freeware CDs v4  and  v5
$!       or from the following URL on the COMPAQ WEB site:
$!       http://www.openvms.compaq.com/freeware/freeware40/dcl_diet/
$!
$! QUALITY
$! Due to the complexity of this processing, your feedback is VERY welcome to
$! mailto:Didier.Morandi@Free.fr or within the comp.os.vms forum. Thank you.
$!
$! LEGAL
$! This procedure is a NothingWare product from MORANDI Consultants illimited.
$! (http://didier.morandi.free.fr/index_us.html).
$!
$! Revision history
$!
$! Version Date        Author     action
$! ------- ----------- ---------- ---------------------------------------------
$! v1.0-0  07-feb-2002 D. Morandi creation
$v="1.1-0"!14-feb-2002 DMo.       add comments before release to c.o.v.
$!-
$ on warning then exit
$ say = "write sys$output"                                     !terminal or file
$ if p1 .eqs. "" then goto HELP
$ say1 = "write sys$error"                                     !always visible
$ if f$search(p1) .eqs. ""
$ then
$    say "File ",p1," not found."
$    exit
$ endif
$ say ""
$ say "This is DCL_ANALYST v",v
$ say ""
$ say2 = "!"                                                    !"V" quiet mode
$ say3 = "!"                                                    !idem for "C"
$ param = f$edit(p2,"upcase")
$ if f$locate("V",param) .ne. f$len(param) then say2 = say
$ if f$locate("C",param) .ne. f$len(param) then say3 = say
$ dq[0,8]=34                                                    ! "
$ sq[0,8]=39                                                    ! '
$ qq = sq + sq                                                  ! ''
$ nb_at    = 0
$ nb_read  = 0
$ nb_write = 0
$ nb_openr = 0
$ nb_openw = 0
$ nb_opena = 0
$ nb_close = 0
$ nb_locas = 0
$ nb_glbas = 0
$ nb_subst = 0
$!+
$! If we have good old DCL_DIET in our login directory, as all DCL programmers
$! should, let's diet the procedure before starting the processing (faster).
$!-
$ workfile = p1 - f$parse(p1,,,"type") - f$parse(p1,,,"version") + ".WORK"
$ if f$search("SYS$LOGIN:DCL_DIET.COM") .nes. ""
$ then
$    say1 "preprocessing file with DCL_DIET..."
$    define/nolog sys$output nl:
$    @sys$login:dcl_diet 'p1' 'workfile'
$    deass sys$output
$    say1 "done."
$ else
$    say -
 "Source file will not be DIETed, DCL_DIET.COM missing in sys$login (how come?)"
$    copy 'p1' 'workfile'
$ endif
$!+
$! Now we ease line analysis by removing these spaces which break f$element...
$!-
$ temp_file = "sys$login:edt_temp_" + f$getjpi(0,"pid") + ".temp"
$ crea 'temp_file'
$DECK
s/$ /$/w/not 
s/ == /==/w/not 
s/ ==/==/w/not 
s/== /==/w/not 
s/ = /=/w/not 
s/= /=/w/not 
s/ =/=/w/not 
s/ := /:=/w/not 
s/:= /:=/w/not 
s/ :=/:=/w/not 
exit
$EOD
$ edit = "edit"
$ edit/edt/command='temp_file' 'workfile'
$ delete = "delete"
$ delete 'temp_file';
$!+
$! Let's redirect the result into the user supplied file.
$!-
$ if p3 .nes. ""
$ then
$    say "Processing output redirected to ",p3
$    define/nolog sys$output 'p3'
$ endif
$!+
$! Now we load the source file in memory, to have direct access to all lines.
$!-
$ close/nolog ch
$ open/read ch 'workfile'
$ i==1                                          !this one should be a global s.
$ say1 "Loading file..."
$LOOP:
$ read/end=EOF ch line_'i'
$ line = f$edit(line_'i',"trim,upcase,compress,uncomment")
$ if line .eqs. "" .or. line .eqs. "$" .or. line .eqs. " " then goto LOOP
$ j=i                                           !this one allows src navigation
$LOOP_CONT:
$!+
$! we have a continuation line, let's concatenate it (much easier to process)
$!-
$ if f$extract(f$len(line_'i')-1,1,line_'i') .eqs. "-"
$ then
$    j=j+1
$    read/end=EOF ch line_'j'
$    line_'i' = f$extract(0,f$len(line_'i')-1,line_'i') + line_'j'
$    goto LOOP_CONT
$ endif
$ i==i+1
$ goto LOOP
$!+
$! We have loaded all the source, let's process each line now.
$!-
$EOF:
$ close ch
$ purge ="purge"
$ purge 'workfile'
$ nb_max = i - 1
$ i==1
$ we_are_within_a_DECK = 0
$ we_are_within_a_HTML_comment = 0
$LOOP2:
$ line = f$edit(line_'i',"trim,upcase,compress,uncomment")      !in case we
$ line_len = f$len(line)                                        !did not have
$ if line_len .eq. 0 then pipe i==i+1 ; goto LOOP2              !DCL_DIET.
$ if line .eqs. "$"  then pipe i==i+1 ; goto LOOP2
$!+
$! If we are within a DECK/EOD pair, this is plain text, do nothing.
$!-
$ if we_are_within_a_DECK
$ then
$    if f$extract(0,4,line) .eqs. "$EOD" then we_are_within_a_DECK = 0
$    i==i+1
$    if i .gt. nb_max then goto ERROR_IN_DECK
$    goto LOOP2
$ endif
$!+
$! are we entering a DECK/EOD pair?
$!-
$ if f$extract(0,5,line) .eqs. "$DECK"
$ then
$    we_are_within_a_DECK = 1
$    i==i+1
$    if i .gt. nb_max then goto ERROR_IN_DECK
$    goto LOOP2
$ endif
$!+
$! If we are within an HTML comment, do nothing too.
$!-
$ if we_are_within_a_HTML_comment
$ then
$    if f$extract(0,,line) .eqs. "-->" then we_are_within_a_HTML_comment = 0
$    i==i+1
$    if i .gt. nb_max then goto ERROR_IN_HTML_COMMENT
$    goto LOOP2
$ endif
$!+
$! are we entering an HTML comment?
$!-
$ if f$extract(0,4,line) .eqs. "<!--"
$ then
$    we_are_within_a_HTML_comment = 1
$    i==i+1
$    if i .gt. nb_max then goto ERROR_IN_HTML_COMMENT
$    goto LOOP2
$ endif
$!+
$! let's build the line number with fancy formatting (courtesy John D. McLean).
$!-
$ line_nr = "00000"
$ line_nr[5-f$len(i),f$len(i)] := 'i'
$!+
$! The "symbol substitution within a string" processing.
$!-
$ pos_qq = f$locate(qq,line)
$ if pos_qq .ne. line_len
$ then
$ temp_line = line
$AGAIN:
$    remain = f$extract(pos_qq+2,999,temp_line)
$    pos_sq = f$locate(sq,remain)
$    if pos_sq .ne. f$len(remain)
$    then
$       subst_var = f$edit(f$extract(0,pos_sq,remain),"upcase")
$       if f$locate("F$",subst_var) .ne. f$len(subst_var) then goto EXIT_VAR
$       say2 line_nr," VARSUBS ",subst_var," substituted within string"
$       nb_subst = nb_subst + 1
$    else
$       say1 "*** ERROR line ",i," - Unclosed substitution within string."
$       say1 line
$    endif
$    pos_qq = f$locate(qq,remain)
$    if pos_qq .ne. f$len(remain)
$    then
$       temp_line = remain
$       goto AGAIN
$    endif
$ endif
$EXIT_VAR:
$!+
$! The "global symbol assignment" processing.
$!-
$ pos_eqeq = f$locate("==",line)
$ if pos_eqeq .ne. line_len
$ then
$    symbol = f$element(0,"=",line)
$    if symbol .eqs. "=" then call WARNING_ELEMENT globass symbol
$    if f$locate("/",symbol) .ne. f$len(symbol) then goto EXIT_SYMBOL
$    if f$extract(0,1,symbol) .eqs. "$" then symbol = f$extract(1,999,symbol)
$    value = f$element(2,"=",line)
$    if value .eqs. "=" then call WARNING_ELEMENT globass value
$    if f$locate("F$",value) .ne. f$len(value) then goto EXIT_SYMBOL
$    symbol = f$edit(symbol,"trim")
$    value = f$edit(value,"trim")
$    if value .eqs. " " then value = """ """
$    if value .eqs. "" then value = "(missing)"
$    if value .nes. "-"
$    then
$       say2 line_nr," GLOBASS Global symbol ",symbol," receives value ",value
$       nb_glbas = nb_glbas + 1
$    else
$       say1 line_nr, -
        " GLOBASS ",symbol," receives value on a continuation line" 
$    endif
$ else
$!+
$! The "local symbol assignment" processing.
$!-
$    pos_eq = f$locate("=",line)
$    if pos_eq .ne. line_len
$    then
$       symbol = f$element(0,"=",line)
$       if symbol .eqs. "=" then call WARNING_ELEMENT locass symbol
$       if f$locate("/",symbol) .ne. f$len(symbol) then goto EXIT_SYMBOL
$       if f$extract(0,1,symbol) .eqs. "$" then symbol = f$extract(1,999,symbol)
$       symbol = f$edit(symbol,"trim")
$       if f$locate(" ",symbol) .eq. f$len(symbol)              !it is a symbol
$       then
$          value = f$element(1,"=",line)
$          if value .eqs. "=" then call WARNING_ELEMENT locass value
$          if f$locate("F$",value) .ne. f$len(value) then goto EXIT_SYMBOL
$          value = f$edit(value,"trim")
$          if value .eqs. " " then value = """ """
$          if value .eqs. "" then value = "(missing)"
$          if value .nes. "-"
$          then
$             say2 line_nr," LOCASS  ",symbol," receives value ",value
$             nb_locas = nb_locas + 1
$          else
$             say1 line_nr, -
           " LOCASS  ",symbol," receives value on a continuation line" 
$          endif
$       endif
$    endif
$ endif
$EXIT_SYMBOL:
$!+
$! The "Open/read or default READ" file processing.
$!-
$ if f$extract(0,6,line) .eqs. "$OPEN " .or. -
     f$extract(0,7,line) .eqs. "$OPEN/R"
$ then
$    channel = f$element(1," ",line)
$    if channel .eqs. "=" then call WARNING_ELEMENT read channel
$    opened_file = f$element(2," ",line)
$    if opened_file .eqs. "=" then call WARNING_ELEMENT read file
$    say2 line_nr," OPENRD  ",opened_file," opened for READ on channel ",channel
$    nb_openr = nb_openr + 1
$ endif
$!+
$! The "Open/Write file" processing.
$!-
$ if f$extract(0,7,line) .eqs. "$OPEN/W"
$ then
$    channel = f$element(1," ",line)
$    if channel .eqs. "=" then call WARNING_ELEMENT write channel
$    opened_file = f$element(2," ",line)
$    if opened_file .eqs. "=" then call WARNING_ELEMENT write file
$    say2 line_nr," OPENWR  ",opened_file," opened for WRITE on channel 
",channel
$    nb_openw = nb_openw + 1
$ endif
$!+
$! The "Open/Append file" processing.
$!-
$ if f$extract(0,7,line) .eqs. "$OPEN/A"
$ then
$    channel = f$element(1," ",line)
$    if channel .eqs. "=" then call WARNING_ELEMENT append channel
$    opened_file = f$element(2," ",line)
$    if opened_file .eqs. "=" then call WARNING_ELEMENT append file
$    say2 line_nr," OPENAP  ",opened_file," opened for APPEND on channel 
",channel
$    nb_opena = nb_opena + 1
$ endif
$!+
$! The "Close file" processing.
$!-
$ if f$extract(0,7,line) .eqs. "$CLOSE ".or.f$extract(0,7,line) .eqs. "$CLOSE/"
$ then
$    channel = f$element(1," ",line)
$    if channel .eqs. "=" then call WARNING_ELEMENT close channel
$    say2 line_nr," CLOSED  Channel ",channel," closed"
$    nb_close = nb_close + 1
$ endif
$!+
$! The "Read from file" processing.
$!-
$ if f$extract(0,6,line) .eqs. "$READ ".or.f$extract(0,6,line) .eqs. "$READ/"
$ then
$    channel = f$element(1," ",line)
$    if channel .eqs. "=" then call WARNING_ELEMENT read channel
$    record_name = f$element(2," ",line)
$    if record_name .eqs. "=" then call WARNING_ELEMENT read record
$    say2 line_nr," READ    Record ",record_name," read from channel ",channel
$    nb_read = nb_read + 1
$ endif
$!+
$! The "Write to file" processing.
$!-
$ if f$extract(0,7,line) .eqs. "$WRITE ".or.f$extract(0,7,line) .eqs. "$WRITE/"
$ then
$    channel = f$element(1," ",line)
$    if channel .eqs. "=" then call WARNING_ELEMENT write channel
$    record_name = f$element(2," ",line)
$    if record_name .eqs. "=" then call WARNING_ELEMENT write record
$    say2 line_nr," WRITE   Record ",record_name," written to channel ",channel
$    nb_write = nb_write + 1
$ endif
$!+
$! The "@" processing.
$!-
$ at_loc = f$locate("@",line)
$ if at_loc .ne. line_len
$ then
$    gosub CHECK_AT_WITHIN_STRING
$    called_proc = f$element(1,"@",line)
$    called_proc = f$element(0," ",called_proc)
$    if we_are_not_within_a_string
$    then
$       nb_at = nb_at + 1
$       say3 line_nr," XPRCALL External call to ",called_proc
$    endif
$ endif
$!+
$! And that's it for this version.
$!-
$ i==i+1
$ if i .le. nb_max then goto LOOP2
$ say ""
$ say nb_max," lines processed from work file ",workfile
$ say ""
$ say "This is the analysis of file ",f$search(p1)
$ say "done on ",f$time()
$ say "-----------------------------------------"
$ say "Nr of external procedures called        : ",nb_at
$ say "Nr of OPEN or OPEN/READ                 : ",nb_openr
$ say "Nr of OPEN/WRITE                        : ",nb_openw
$ say "Nr of OPEN/APPEND                       : ",nb_opena
$ say "Nr of READ  (any type)                  : ",nb_read
$ say "Nr of WRITE (any type)                  : ",nb_write
$ say "Nr of CLOSE                             : ",nb_close
$ say "Nr of local  symbols assignments        : ",nb_locas
$ say "Nr of global symbols assignments        : ",nb_glbas
$ say "Nr of symbol substitutions within string: ",nb_subst
$ say "-----------------------------------------"
$ say "This result was produced with ",f$env("procedure")
$ node = f$trnlnm("sys$node") - "::"
$ say "on node ",node," by user ",f$getjpi(0,"username")
$ say1 "End of analysis for file ",p1
$ dele_/symb/global i
$ if p3 .nes. ""
$ then
$    deass sys$output
$    say "Result is in ",p3
$ endif
$ exit
$!
$ERROR_IN_DECK:
$ say1 "*** ERROR Infinite loop detected within DECK processing."
$ exit
$!
$ERROR_IN_HTML_COMMENT:
$ say1 "*** ERROR Infinite loop detected within HTML comment processing."
$ exit
$!
$WARNING_ELEMENT:
$ subroutine
$ say1 "*** WARNING f$element returned separator instead of symbol value line ",i
$ say1 "routine name is ",p1
$ say1 "symbol name  is ",p2
$ exit
$ endsubroutine
$!------------------------------------------------------------------------------
$CHECK_AT_WITHIN_STRING:
$!
$!      v--------------------- string_to_scan ----------------------v
$!      $ html do_a "mailto:nicholas-za.senrab@sbu.com" "Nick Senrab"
$!                  !                                 ! !           !
$!                  +-- dq_1_loc           dq_2_loc --+ !           !
$!                                           dq_3_loc --+           !
$!                                                       dq_4_loc --+
$ dq_nr = 1
$ dq_1_loc = 0
$ dq_2_loc = 0
$ string_to_scan = line
$ offset = 0
$DQ_LOOP:
$ dq_'dq_nr'_loc = f$locate("""",string_to_scan)
$ if dq_'dq_nr'_loc .ne. f$len(string_to_scan)
$ then
$    real_loc = dq_'dq_nr'_loc + offset
$    offset = offset + dq_'dq_nr'_loc + 1
$    string_to_scan = f$extract(dq_'dq_nr'_loc + 1,255,string_to_scan)
$    dq_nr = dq_nr + 1
$    goto DQ_LOOP
$ endif
$ dq_nr = dq_nr - 1
$ dq_2_loc = dq_2_loc + offset
$ we_are_not_within_a_string = 1
$ if at_loc .gt. dq_1_loc .and. at_loc .lt. dq_2_loc then -
     we_are_not_within_a_string = 0
$ if dq_nr - (('dq_nr'/2)*2) .ne. 0
$ then
$    say1 "*** ERROR Unclosed double quote detected line ''line_nr' ***"
$    say1 line
$ endif
$ return
$!
$HELP:
$ type/page sys$input
$DECK
Welcome to DCL_ANALYST

This simple tool scans a DCL procedure and gives this kind of result:

        $ @dcl_analyst DSL_MANAGE.COM

        This is the analysis of file USER_DISK:[FRED]DSL_MANAGE.COM;1
        done on 14-FEB-2002 09:46:57.96
        -----------------------------------------
        Nr of external procedures called        : 67
        Nr of OPEN or OPEN/READ                 : 13
        Nr of OPEN/WRITE                        : 4
        Nr of OPEN/APPEND                       : 2
        Nr of READ  (any type)                  : 83
        Nr of WRITE (any type)                  : 77
        Nr of CLOSE                             : 21
        Nr of local  symbols assignments        : 425
        Nr of global symbols assignments        : 12
        Nr of symbol substitutions within string: 395
        -----------------------------------------
        This result was produced with USER_DISK:[FRED]DCL_ANALYST.COM;98765
        on node MYNODE by user FRED.

When called, DCL_ANALYST accepts the following parameters:

        P1      full filename of procedure to be analysed

        P2      flag:
                V = display assigned and substituted variables
                C = display called procedures
                P2 can be supplied with both flags together, i.e.

                $ @dcl_analyst myproc.com VC

        P3      output file for the resulting display to be stored in.
                If an output file is to be produced and no values are
                supplied for parameter P2, P2 should be place-holded
                with a null string, i.e.

                $ @dcl_analyst myproc.com "" result.txt

                The output file is stored in your default directory.

[end of HELP]
$EOD
$ exit