$!***************************************************************************
$!*                                                                         *
$!*  DCL_DIET.COM                                                           *
$!*                                                                         *
$!* © Copyright 1976, 2004 Hewlett-Packard Development Company, L.P.        *
$!*                                                                         *
$!* Confidential computer software.  Valid license from HP and/or           *
$!* its subsidiaries required for possession, use, or copying.              *
$!*                                                                         *
$!* Consistent with FAR 12.211 and 12.212, Commercial Computer Software,    *
$!* Computer Software Documentation, and Technical Data for Commercial      *
$!* Items are licensed to the U.S. Government under vendor's standard       *
$!* commercial license.                                                     *
$!*                                                                         *
$!* Neither HP nor any of its subsidiaries shall be liable for technical    *
$!* or editorial errors or omissions contained herein.  The information     *
$!* in this document is provided "as is" without warranty of any kind and   *
$!* is subject to change without notice.  The warranties for HP products    *
$!* are set forth in the express limited warranty statements accompanying   *
$!* such products.  Nothing herein should be construed as constituting an   *
$!* additional warranty.                                                    *
$!*                                                                         *
$!***************************************************************************
$!
$!  Abstract:   "DIET" a DCL .COM procedure by removing all comments
$!              and reducing all spaces to a single space
$!
$!    Author:   Charlie Hammond
$!
$!   Created:   15-Sep-1998
$!
$!    Inputs:   P1 -- The file to be "dieted"
$!
$!   Outputs:   P2 -- The "dieted" file
$!
$!  MODIFICATION HISTORY
$!
$!  V1.2        2006 MAY-01         Charlie Hammond
$!      Handle $DECKs with /DOLLARS
$!
$!  V1.1        2004-AUG-19         Charlie Hammond
$!      Do not diet any line containing "''F$" or "''f$".
$!      This avoids errors made by F$EDIT.
$!
$!  October 2002
$!      If the translation of the logical name DCL$DIET_DOTDOT is true, then
$!      add a space a the beginning of a line that starts with ".".
$!      This is to overcome a problem with SMTP mail in Compaq TCP/IP services
$!      so that TCP/IP V5.3-18's SMTP won't double the "."
$!
$!  15-Dec-1999 -- cleaned up a few code details
$!
$!
$! ---------------------------------------------------------------------------
$   goto start
$!  This $DECK remains after DCLDIET is run to give a hint...
$DECK
    **************************************************************

    This procedure "DIETs" a command procedure file -- compressing
    it by removing comments and unnecessary space. This saves file
    space and improves execution time.  It may also remove comments
    that you don't want users to see.

    To run this procedure, enter command

        $@DCL_DIET <input> <output>

        where   <input> is the input command procedure
               <output> is the "DIETed" output file

    If you use DCL_DIET frequently, you may wish to assign a symbol in
    your LOGIN.COM file to execute DCL_DIET.  For example, if the
    DCL_DIET.COM is in you LOGIN default directory, you might put the
    following in your LOGIN.COM:

        $ DCL_DIET :== "@SYS$LOGIN:DCL_DIET"

    Alternatively, if you put DCL_DIET.COM in SYS$SYSTEM, you might put
    the following in your SYS$SYLOGIN (which is normally
    SYS$MANAGER:SYLOGIN.COM):

        $ DCL_DIET :== "@SYS$SYSTEM:DCL_DIET"

    If the translation of the logical name DCL$DIET_DOTDOT is true, then
    this version adds a space a the beginning of a line that starts with ".".
    This is to overcome a problem with SMTP mail in Compaq TCP/IP services
    so that TCP/IP V5.3-18's SMTP won't double the "."

    **************************************************************
$EOD
$start:
$!
$!  Make sure DCL verbs aren't unexpected symbols.
$!
$   set = "set"
$   set symbol /scope=(nolocal,noglobal)
$!
$!  Set up to handle CTRL_Y and errors.
$!
$   sav_status = 1      ! Default to success
$!
$   say = "write sys$output"
$!
$   on control_y then goto y_exit
$   on warning then goto err_exit
$!
$   if f$trnlnm("DCL$DIET_DOTDOT")
$   then
$       dot$dot = 1
$   else
$       dot$dot = 0
$   endif
$!
$   in$deck = 0                 ! indicate not in a $DECK/$EOD
$   continuation$line = 0       ! indicate not a continuation line
$   dollars$ = "="              ! No /DOLLARS on $DECI
$!
$!  Create a symbol for the single quote character (')
$   s_quote[0,8]=39
$!
$!  And, everybody's favorite, a symbol for "''F$"
$   s2_upr = s_quote + s_quote + "F$"
$   s2_lwr = s_quote + s_quote + "f$"
$!
$   lines_in = 0
$   lines_out = 0
$!
$   line_disply_increment = 500
$   line_to_display = line_disply_increment - 1
$!
$!  ------------------------------------------------------------------
$!
$   dcl_dt_vers = "V1.2"
$   say ""
$   say -
    "-*- Charlie Hammond's unsupported DCL DIETer (Version ''dcl_dt_vers') -*-"
$   say ""
$!
$!
$!  If p1 is not presnt, prompt for it.
$!
$get_p1:
$!
$   if p1 .eqs. ""
$   then
$       read /error=get_p1 sys$output p1 -
            /prompt="Enter name of file to be Dieted: "
$       goto get_p1
$   endif
$!
$!  Verify that the input file exists.
$!
$   if f$search(p1) .eqs. ""
$   then
$       say "Cannot find ""''p1'"""
$       p1 = ""
$       goto get_p1
$   endif
$!
$   diet$input = f$parse(p1)
$!
$!  If p2 is not present, prompt for it.  Use "''p1'_dieted" as the default.
$!
$get_p2:
$!
$!  Append p2, p3 and p4
$   p2 = p2 + p3 + p4
$!
$   if p2 .eqs. ""
$   then
$       say "The default for the ""dieted"" output file is"
$       say """''diet$input'_DIET""" - ";"
$       read /error=get_p2 sys$output p2 -
            /prompt="Enter name of file for output: "
$       if p2 .eqs. "" then p2 = "''diet$input'_DIET" - ";"
$   endif
$!
$   diet$output = f$parse(p2,diet$input)
$!
$   if diet$output .eqs. ""
$   then
$       say "*** ""''p2'"" is not a valid filename"
$       p2 = ""
$       goto get_p2
$   endif
$!
$   say " Input file is: " + diet$input
$   say "Output file is: " + diet$output
$   say "Starting -- ''f$time()'"
$!
$!
$!  Open the output file
$!
$!  CREATE it and APPEND to it to get proper file attributes
$!
$   create 'diet$output'
$!  Close it first, just in case
$   close /error=open_output diet$output
$open_output:
$   open /append diet$output 'diet$output'
$!
$   write diet$output "$! File created by DCL_DIET at ''f$time()' from"
$   write diet$output "$! ''diet$input'"
$   if dot$dot then -
    write diet$output "$! (Space added before ""."" at beginning of record)"
$!
$!
$!  Open the input file
$!
$!  Close it first, just in case
$   close /error=open_input diet$input
$open_input:
$   open /read diet$input 'diet$input'
$!
$!
$!   Read the input file
$!
$read_input:
$!
$   read /end=common_exit diet$input record_in
$   lines_in = lines_in + 1
$!
$   if lines_in .gt. line_to_display
$   then
$       say f$fao("...processing line number !UL...",lines_in)
$       line_to_display = line_to_display + line_disply_increment
$   endif
$!
$!
$!  temporarily compress the line
$   temp = f$edit(record_in,"TRIM,COMPRESS,UPCASE")
$!
$!  Skip comment only lines
$   if ( ( f$extract(0,2,temp) .eqs. "$!" ) -
    .or. ( f$extract(0,3,temp) .eqs. "$ !" ) ) -
    then goto read_input
$!
$!  Get the first two tokens on the line
$   t0 = f$element(0," ",temp)
$   t1 = f$element(2," ",temp)
$!
$!  Check if in a $DECK/$EOD.
$!
$   if in$deck
$   then
$       if (t0 .eqs. "$EOD") .or. ( (t0 .eqs. "$") .and. (t1 .eqs. "EOD") ) -
        .or. ( (dollars$ .nes. "=") .and. (t0 .eqs. dollars$) )
$       then
$           in$deck = 0 
$           if dollars$ .eqs. "="
$           then
$               write diet$output "$EOD"
$           else
$               write diet$output dollars$
$           endif
$           lines_out = lines_out + 1
$           continuation$line = 0       ! indicate not a continuation line
$           goto read_input
$       endif
$   else ! not in$deck
$       if (t0 .eqs. "$DECK") .or. ( (t0 .eqs. "$") .and. (t1 .eqs. "DECK") )
$       then
$           in$deck = 1
$           write diet$output "$DECK"
$           lines_out = lines_out + 1
$           continuation$line = 0       ! indicate not a continuation line
$!          Check for /DOLLARS -- which must be the ONLY "=" sign
$           dollars$ = -
                f$edit(f$element(1,"=",temp),"TRIM,COLLAPSE,UNCOMMENT,UPCASE")
$           dollars$ = f$edit(f$element(1,"=",temp),"TRIM")
$           goto read_input
$       endif
$   endif
$!
$!  If in a $DECK do not diet the line.
$!
$   if in$deck
$       then
$       write diet$output record_in
$       lines_out = lines_out + 1
$       continuation$line = 0       ! indicate not a continuation line
$       goto read_input
$   endif
$!
$!  Do not diet lines that do not start with "$" and are NOT continuation lines
$!
$   if ( ( f$extract(0,1,temp) .nes. "$" ) .and. ( .not. continuation$line ) )
$   then
$       write diet$output record_in
$       lines_out = lines_out + 1
$       continuation$line = 0       ! indicate not a continuation line
$       goto read_input
$   endif
$!
$!  Anything that gets here is NOT in a $DECK, and either starts with "$"
$!      or is a continuation line.
$!
$!
$!  We want to TRIM, COMPRESS and UNCOMMENT the dcl record,
$!  But first we must deal with problem that F$EDIT has:
$!
$!      - Exclaimation marks used for formating directives in F$FAO
$!        control strings may be taken as comments and removed.
$!        This only occurs when the F$FAO is preceded by two single quotes
$!        indicating symbol substitution within a quoted string.   e.g.
$!
$!          $ write sys$output "Value is: ''f$fao("!4UL",value)'"
$!
$!      - Multiple spaces in strings within a lexical function may be
$!        incorrectly compressed.  Again, This only occurs when a lexical
$!        function is preceded by two single quotes indicating symbol
$!        substitution within a quoted string.   e.g.
$!
$!          $ write sys$output "''f$locate("  a","        a")'"
$!
$!      (These may not be good coding practice, but they ARE used.)
$!
$!  We could write a lot of clumsy code to handle this, but since it is
$!  an unusual occurance, we just skip dieting any lines that contain
$!  the string "''F$" or the string "''f$'"
$!
$   in_length = f$length(record_in)
$   if ( (f$locate(s2_lwr,record_in) .lt. in_length) -
    .or. (f$locate(s2_upr,record_in) .lt. in_length) ) -
        then goto do_fao
$!
$   goto not_fao
$!
$do_fao:
$!  Don't COMPRESS or UNCOMMENT it
$   record_out = f$edit(record_in,"TRIM")
$   goto after_fao
$!
$not_fao:
$!  Now we can diet it with f$edit
$   record_out = f$edit(record_in,"TRIM,COMPRESS,UNCOMMENT")
$   goto after_fao
$!
$after_fao:
$!
$   continuation$line = 0           ! indicate not a continuation line
$!
$!  Skip coment only and blank lines
$   if record_out .eqs. "$" then goto read_input
$!
$check_$:
$   if f$extract(0,2,record_out) .eqs. "$ "
$   then
$       record_out = "$" + record_out - "$ "
$       goto check_$
$   endif
$!
$!  If necessary, add a leading space so that TCP/IP V5.3's SMTP
$!  won't double the "."
$   if dot$dot .and. ( f$extract(0,1,record_out) .eqs. "." ) -
        then record_out = " " + record_out
$!
$   write diet$output record_out
$   lines_out = lines_out + 1
$   if f$extract(f$length(record_out)-1,1,record_out) .eqs. "-" -
        then continuation$line = 1  ! indicate a continuation line
$   goto read_input
$!
$!
$!  ------------------------------------------------------------
$!  Exit routines
$!
$y_exit:        ! Ctrl_y exit routine
$!
$!  Display Ctrl_y message
$!
$   write sys$output "Exiting due to Ctrl_y entry"
$!
$   goto 1_exit
$!
$!
$err_exit:      ! error/warning exit routine
$!
$   sav_status = $status
$!
$   write sys$output f$message(sav_status)
$!  Add %x10000000 to set the bit that suppresses display of the message.
$!  This prevents re-displaying the message when we EXIT SAV_STATUS.
$   if sav_status .lt. %x10000000 then sav_status = sav_status + %x10000000
$   goto common_exit
$!
$1_exit:        ! Go here to force exit with status 1 = success
$!                %SYSTEM-S-NORMAL, normal successful completion
$!
$!  Display success message
$!
$   write sys$output f$message(sav_status)
$!
$!  Note: success messages aren't displayed by EXIT SAV_STATUS.
$!  Don't need to use %x10000001.
$   sav_status = 1
$   goto common_exit
$!
$common_exit:   ! common exit
$!
$!  Disable control_y and error handling
$   on control_y then continue
$   on warning then continue
$!
$!  Cleanup code
$!
$!  Close any file left open...
$!
$   close /error=exit_output diet$output
$exit_output:
$   close /error=exit_input diet$input
$exit_input:
$!
$   say "Finished -- ''f$time()'"
$   say ""
$   say f$fao("!7UL lines read",lines_in)
$   say f$fao("!7UL lines written",lines_out)
$   say ""
$!
$!  Exit with status
$!
$   exit sav_status