You are here: DBG/400>DBG400 Web>SourceCodeList>RpgleSource>RpgleDBG101R4 (revision 1)EditAttach
      **********************************************************************************************
      * DBG101R4: Database generation script selection
      * Copyright (C) 2000  Martin Rowe   <martin@dbg400.net>
      *
      * This program is free software; you can redistribute it and/or modify
      * it under the terms of the GNU General Public License as published by
      * the Free Software Foundation; either version 2 of the License, or
      * (at your option) any later version.
      *
      * This program is distributed in the hope that it will be useful,
      * but WITHOUT ANY WARRANTY; without even the implied warranty of
      * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
      * GNU General Public License for more details.
      *
      * You should have received a copy of the GNU General Public License
      * along with this program; if not, write to the Free Software
      * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
      **********************************************************************************************
     H DATEDIT(*YMD) DEBUG(*YES) OPTION(*NODEBUGIO : *SRCSTMT)
      **********************************************************************************************
      * INDICATOR USAGE:
      **********************************************************************************************
      *     File access inds
      *  80  81  82  83
      *     Error ind (for calls)
      *  90
      **********************************************************************************************
      * FILES:
      **********************************************************************************************
      **********************************************************************************************
      * ARRAYS:
      **********************************************************************************************
     D P#OutStrs       S            132    DIM(50)
      **********************************************************************************************
      * DATA STRUCTURES:
      **********************************************************************************************
      *  PROGRAM NAME
     D                SDS
     D SDS#PGM                       10
      **********************************************************************************************
      * WORK FIELDS:
     D MbrOpt          S              2
     D P#CmdChk        S             74
     D P#CmdChkLen     S             15  5
     D P#InString      S            132
     D P#Field         S             10
     D P#File          S             10
     D P#Return        S              7
     D P#Sequence      S              2  0
     D P#Source        S             10
     D P#Target        S             10
     D P#Text          S             50
     D P#TextLine      S            132
     D P#WordNbr       S              3  0
     D Sequence        S              2
      **********************************************************************************************
      * CONSTANTS:
      **********************************************************************************************
     D Lower           C                   CONST('abcdefghijklmnopqrstuvwxyz')
     D Upper           C                   CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
      **********************************************************************************************
      * ENTRY PARAMETERS:
      **********************************************************************************************
     C     *ENTRY        PLIST
     C                   PARM                    P#TextLine
      **********************************************************************************************
      * KEY LISTS:
      **********************************************************************************************
      **********************************************************************************************
      * MAINLINE:
      **********************************************************************************************
      * Only process non-comment lines
B001 C                   IF        %SUBST(P#TextLine:1:1) <> ';'
     C                   CALL      'DBG041R4'                           90
     C                   PARM      P#TextLine    P#InString                     Text entry
     C                   PARM      0             P#WordNbr                      Returned entries
     C                   PARM      *blanks       P#OutStrs                      Returned data
      * Wrap to upper case first of all
     C     Lower:Upper   XLATE     P#OutStrs(1)  P#Target
     C     Lower:Upper   XLATE     P#OutStrs(2)  P#Source
      * Process the line according to its type
B002 C                   SELECT
      * SQL directive - use field prompting
S002 C                   WHEN      P#Target = '*SQLSEL'
     C                             OR P#Target = '*SQLUPD'
     C                             OR P#Target = '*SQLDLT'
     C                   CALL      'DBG105CL'
     C                   PARM      P#Source      P#File
     C                   PARM      ' '           P#Field
      * If field selected, add it at the end of the statement, and put the cursor after it
B003 C                   IF        P#Field <> *blanks
     C                   EVAL      P#TextLine = %TRIM(P#TextLine) + ' ' +
     C                             P#Field
E003 C                   ENDIF
      * Command directive - prompt required
S002 C                   WHEN      P#Target = '*CMD'
     C                   EVAL      P#CmdChk = '?' + %SUBST(P#TextLine : 6 : 74)
     C                   CALL      'QCMDCHK'
     C                   PARM                    P#CmdChk
     C                   PARM      74            P#CmdChkLen
     C                   EVAL      P#TextLine = '*CMD ' + P#CmdChk
      * Nothing to do for a *CALL directive
S002 C                   WHEN      P#Target = '*CALL'
      * Nothing to do for a *CPYRCDS directive
S002 C                   WHEN      P#Target = '*CPYRCDS'
      * Otherwise this is a link - prompt using the target file (if entered)
S002 C                   OTHER
     C                   EVAL      Sequence = P#OutStrs(3)
      * If the fourth word is the replace switch, keep it for later
B003 C                   IF        P#OutStrs(4) = '/r'
     C                             OR P#OutStrs(4) = '/R'
     C                   EVAL      MbrOpt = '/r'
E003 C                   ENDIF
      * Convert sequence to numeric for key positioning
     C                   MOVE      Sequence      P#Sequence
     C                   CALL      'DBG100R4'                           90
     C                   PARM                    P#Target
     C                   PARM                    P#Source
     C                   PARM                    P#Sequence
     C                   PARM                    P#Text
     C                   PARM                    P#Return
      * Rebuild line if a link (or script) selected
B003 C                   IF        P#Return = '*SELECT'
     C                   MOVE      P#Sequence    Sequence
     C                   EVAL      P#TextLine = %TRIM(P#Target) + ' ' +
     C                             %TRIM(P#Source) + ' ' + %TRIM(Sequence) +
     C                             ' ' + MbrOpt + ' ' + %TRIM(P#Text)
E003 C                   ENDIF
E002 C                   ENDSL
E001 C                   ENDIF
      *  Time to go...
     C     ENDPGM        TAG
      *    ======        ===
     C                   EVAL      *INLR = *on
     C                   RETURN
      **********************************************************************************************
Edit | Attach | Print version | History: r2 < r1 | Backlinks | View wiki text | Edit WikiText | More topic actions...
Topic revision: r1 - 26 May 2005 - 19:19:22 - MartinRowe
 
This site is powered by FoswikiCopyright © by the contributing authors. All material on this collaboration platform is the property of the contributing authors.
Ideas, requests, problems regarding DBG/400? Send feedback