For IBMi (AS400) interactive programs : retrieves position of a field into a screen record format (start column and row)

QRPGLESRC.UTIDSP.rpgle

**free
  //**************************************************************************
  //* MODULE    : UTIDSP                  Date Création : 19/07/2017         *
  //* AUTEUR    : D.LANDRAGIN                                                *
  //*------------------------------------------------------------------------*
  //*  APPLICATION :                                                         *
  //*  Services                                                              *
  //*------------------------------------------------------------------------*
  //*  DESCRIPTION :                                                         *
  //*  Managing screens                                                      *
  //*                                                                        *
  //*------------------------------------------------------------------------*
  //* MAINTENANCE :                                                          *
  //*  N°    AUTEUR                       OBJET                       DATE   *
  //* ...  ...........  .........................................  ../../....*
  //* ...  ...........  .........................................  ../../....*
  //* ...  ...........  .........................................  ../../....*
  //    **********************************************************************
  //    * >>PRE-COMPILER<<                                              */
  //    *   >>CRTCMD<<  CRTRPGMOD MODULE(&LI/&OB) SRCFILE(&SL/&SF) +    */
  //    *                 SRCMBR(&SM);                                  */
  //    *   >>IMPORTANT<<                                               */
  //    *     >>PARM<<  OPTION(*EVENTF);                                */
  //    *     >>PARM<<  DBGVIEW(*ALL);                                  */
  //    *   >>END-IMPORTANT<<                                           */
  //    *   >>EXECUTE<<                                                 */
  //    * >>END-PRE-COMPILER<<                                          */
  //    **********************************************************************
  ctl-opt nomain;
  ctl-opt option(*srcstmt:*nodebugio:*nounref);

  dcl-c USRSPC_NAME 'UTIDSPUSRSQTEMP';       //userspace name
  dcl-c FLDL0100 'FLDL0100';                 //format description for field
  dcl-c MAX_ZONES 300;                       //default max fieds number for a record format

  //API  create userspace
  dcl-pr crtUserSpace extpgm('QUSCRTUS');
    *n char(20) const;  // Name
    *n char(10) const;  // Attribute
    *n int(10) const;   // Initial size
    *n char(1) const;   // Initial value
    *n char(10) const;  // Authority
    *n char(50) const;  // Text
    *n char(10) const options(*nopass);  // Replace existing
    *n char(32767) options(*varsize:*nopass);  // Error feedback
  end-pr;

  //API lists record format fields in the userspace
  dcl-pr listFields extpgm('QUSLFLD');
    *n char(20) const;  // User space name
    *n char(8) const;   // Format
    *n char(20) const;  // File name
    *n char(10) const;  // Record format
    *n char(1) const;   // Use override
    *n char(32767) options(*varsize:*nopass);  // Error feedback
  end-pr;

  //API getting a userspace's pointer
  dcl-pr getPointer extpgm('QUSPTRUS');
    *n char(20) const;   // Name
    *n pointer;          // Pointer to user space
    *n char(32767) options(*varsize:*nopass);  // Error feedback
  end-pr;

  //API de deleting a userspace
  dcl-pr dltUserSpace extpgm('QUSDLTUS') ;
    *n char(20) const ;   // Name
    *n char(32767) options(*varsize:*nopass) ;  // Error feedback
  end-pr ;

  //list Header extracted from userspace
  dcl-ds listHeader based(userSpacePointer) qualified;
    offset int(10) pos(125); //position
    count int(10) pos(133);  //nombre de zones
    size int(10) pos(137);   //taille d'une entrée de la liste
  end-ds;

  Dcl-ds ErrApi qualified;
    ErrLen int(10) inz(%len(ErrApi));  // Bytes provided
    ErrRtn int(10);                // Bytes available
    ErrId char(7);                 // Exception ID
    Filler char(1);                // Reserved  data
    ErrData char(32767);           //  Exception data
  end-ds;

  //a field description
  dcl-ds fieldInfo based(fieldPointer) qualified;
    name      char(10) pos(1);  //nom zone
    dataType  char(1) pos(11);  //type de donnée
    input     int(10) pos(17);  //position début zone
    fldLength int(10) pos(21);  //longrue zone en octets
    digits    int(10) pos(25);  //nombre de chiffres
    dec       int(10) pos(29);  //positions decimales
    row       int(10) pos(449); //ligne à l'écran ou à l'impression
    col       int(10) pos(453); //colonne à l'écran ou à l'impression
  end-ds;

  //record format description template for array
  dcl-ds descFormat_t qualified template;
    name char(10);   //record format name
    nbZones uns(10); //number of fields
    allocFields uns(5); //allocated fields number
    ptrTFields pointer; //fields array's pointer
  end-ds;

  //field description template for array
  dcl-ds descZone_t qualified template;
    name char(10);
    row  int(10);
    col  int(10);
  end-ds;

  //files array description
  dcl-ds tFiles qualified dim(100) based(ptr_files);
    name char(20);          //file name
    nbFormats uns(10);      //number of records formats
    allocFormats uns(5);    //allocated records formats number
    ptrTFormats pointer;    //records formats array's pointer for file
  end-ds;

  dcl-ds tFormats likeds(descFormat_t) dim(100) based(ptr_formats);
  dcl-ds tFields likeds(descZone_t) dim(5000) based(ptr_fields);

  dcl-s idx uns(10); //index of last file referenced into array
  dcl-s allocFiles uns(5) inz(2); //allocated files number

  dcl-c ALLOC_FORMATS 2; //allocated records formats number per file
  dcl-c ALLOC_FIELDS 100; //allocated fields number per record format
  dcl-c INCR_FILES 2;  //increment for reallocating files array
  dcl-c INCR_FORMATS 2;  //increment for reallocating records formats array
  dcl-c INCR_FIELDS 50;  //increment for reallocating fields array

  // --------------------------------------------------
  // Procedure name: dsp_rtvPosition
  // Purpose:        retrieves position of a field in a screen record format
  //                 (col, row) for positionning
  // Returns:
  // Parameter:      p_fichier => file name
  // Parameter:      p_format => record format name
  // Parameter:      p_zone => field name
  // Parameter:      p_colonne => column (I-O)
  // Parameter:      p_ligne => row (I-O)
  // --------------------------------------------------
  DCL-PROC dsp_rtvPosition EXPORT;

    DCL-PI *n;
      p_fichier char(10) const;
      p_format char(10) const;
      p_zone char(10) const;
      p_colonne zoned(3);
      p_ligne zoned(3);
    END-PI;

    dcl-ds w_descZone likeds(descZone_t);

    dcl-ds fichier qualified;
      nom    char(10);
      *n char(10) inz('*LIBL');
    end-ds;

    //file name
    fichier.nom = p_fichier;

    //retrieves description field
    w_descZone = rtvField(fichier:p_format:p_zone);
    //if not found genarate list and retrieve description
    if w_descZone.name = *blanks;
      generateList(fichier:p_format);
      w_descZone = rtvField(fichier:p_format:p_zone);
    endif;

    //if found, loads field's position and returns it
    if w_descZone.name <> *blanks;
      p_colonne = w_descZone.col;
      p_ligne = w_descZone.row;
    endif;

    return;


  END-PROC;

  // --------------------------------------------------
  // Procedure name: dsp_remove
  // Purpose:        free ressources at end
  //
  // Returns:        True
  // --------------------------------------------------
  DCL-PROC dsp_remove EXPORT;

    dcl-pi *n ind end-pi;

    if ptr_files <> *null;
      dealloc(en) ptr_files;
    endif;
    if ptr_formats <> *null;
      dealloc(en) ptr_formats;
    endif;
    if ptr_fields <> *null;
      dealloc(en) ptr_fields;
    endif;
    idx = 0;

    return *on;
  END-PROC;
  // --------------------------------------------------
  // Procedure name: generateList
  // Purpose:        generate fields list for a record format
  // Returns:
  // Parameter:      p_fichier => qualified name for the file
  // Parameter:      p_format => record format name
  // --------------------------------------------------
  DCL-PROC generateList;

    DCL-PI *n;
      p_fichier char(20) const;
      p_format char(10) const;
    END-PI;

    dcl-s idx_f uns(10);  //index fichier
    dcl-s idx_r uns(10);  //sous-index format
    dcl-s i uns(10);      //index zone

    //looking for file reference (references if not)
    idx_f = rtvIdxFile(p_fichier);

    //looking for record format (references if not)
    idx_r = rtvIdxFormat(idx_f:p_format);

    //pointer on record format of file
    ptr_formats = tFiles(idx_f).ptrTFormats;

    //new userspace
    crtUserSpace(USRSPC_NAME:'':131072:x'00':
            '*ALL':'List of fields in file':'*NO':errApi);

    //Lists record format fields
    listFields(USRSPC_NAME
                :FLDL0100:p_fichier:p_format:'0':errApi);

    //get pointer on the user space
    getPointer(USRSPC_NAME:userSpacePointer:errApi);

    //set allocated files for array
    tFormats(idx_r).allocFields = ALLOC_FIELDS;

    //allocate array for list fields and store pointer
    ptr_fields = %alloc(%size(tFields) * tFormats(idx_r).allocFields);
    tFormats(idx_r).ptrTFields = ptr_fields;

    //extracts fields description and populates array
    for i = 1 to listHeader.count;
      if i > tFormats(idx_r).allocFields;
        tFormats(idx_r).allocFields += INCR_FIELDS;
        ptr_fields =
          %realloc(tFormats(idx_r).ptrTFields
                    :%size(tFields) * tFormats(idx_r).allocFields);
        tFormats(idx_r).ptrTFields = ptr_fields;
      endif;
      fieldPointer = userSpacePointer
                     + listHeader.offset
                     + (listHeader.size * (i - 1));
      tFields(i).name = fieldInfo.name; //field name
      tFields(i).row = fieldInfo.row;   //row number
      tFields(i).col = fieldInfo.col;   //column number
    endfor;

    //number of fields for the record format
    tFormats(idx_r).nbZones = listHeader.count;

    //delete userspace
    dltUserSpace(USRSPC_NAME:errApi);

  END-PROC;



  // --------------------------------------------------
  // Procedure name: rtvField
  // Purpose:        Retrieve description for a field name
  // Returns:        la description d'une zone
  // Parameter:      p_fichier => File name
  // Parameter:      p_format => Format name
  // Parameter:      p_zone => Field name
  // --------------------------------------------------
  DCL-PROC rtvField;

    DCL-PI *N likeds(descZone_t);
      p_fichier char(20) const;
      p_format char(10) const;
      p_zone char(10) const;
    END-PI ;

    DCL-DS w_zone LIKEDS(descZone_t);

    dcl-s idx_f uns(10); //index fichier
    dcl-s idx_r uns(10); //sous-index format
    dcl-s idx_z uns(10); //sous-index zone


    if idx > 0;
      //looking for file in the file array
      idx_f = %lookup(%trim(p_fichier):tFiles(*).name:1:idx);

      if idx_f > 0 and tFiles(idx_f).nbFormats > 0;
        ptr_formats = tFiles(idx_f).ptrTFormats;
        idx_r = %lookup(%trim(p_format)
                        :tFormats(*).name
                        :1
                        :tFiles(idx_f).nbFormats
                );
        //looking for the format in the formats sub-array
        if idx_r > 0 and tFormats(idx_r).nbZones > 0;
          ptr_fields = tFormats(idx_r).ptrTFields;
          //looking for the field in the fields sub-array
          idx_z = %lookup(%trim(p_zone)
                          :tFields(*).name
                        :1
                          :tFormats(idx_r).nbZones
                );
        endif;
      endif;
    endif;

    //retrieving description field
    if idx_z > 0;
      w_zone = tFields(idx_z);
    else;
      clear w_zone;
    endif;

    return w_zone;
  END-PROC;




  // --------------------------------------------------
  // Procedure name: rtv_idxFile
  // Purpose:        retrieve the index of a file if referenced (references if not)
  // Returns:        Index of file
  // Parameter:      p_name => File name
  // --------------------------------------------------
  DCL-PROC rtvIdxFile;

    dcl-pi *n uns(10);
      p_name char(20) const;
    end-pi;

    dcl-s index uns(10);

    //looking for file in the files array
    if idx > 0;
      index = %lookup(%trim(p_name):tFiles(*).name:1:idx);
    endif;

    //allocates files array if not exists
    if idx = 0;
      ptr_files = %alloc(%size(tFiles) * allocFiles);
    //increases array size for add to files array if necessary
    elseif index = 0 and (idx + 1) > allocFiles;
      allocFiles += INCR_FILES;
      ptr_files = %realloc(ptr_files:%size(tFiles) * allocFiles);
    endif;

    if index = 0;
      idx += 1;
      index = idx;
      clear tFiles(index);
      tFiles(index).name = p_name;
    endif;

    return index;
  END-PROC;

  // --------------------------------------------------
  // Procedure name: rtv_idxFormat
  // Purpose:        Retrieves the index of a format if referenced (references if not)
  // Returns:        Index du format
  // Parameter:      p_index => Index du fichier
  // Parameter:      p_name => Nom du format
  // --------------------------------------------------
  DCL-PROC rtvIdxFormat;

    dcl-pi *n uns(10);
      p_index uns(10) const;
      p_name char(10) const;
    end-pi;

    dcl-s index uns(10);
    dcl-s i uns(10);

    if idx = 0;
      return index;
    endif;

    //looking for record format
    if tFiles(p_index).nbFormats > 0;
      ptr_formats = tFiles(p_index).ptrTFormats;
      index = %lookup(%trim(p_name)
                      :tFormats(*).name
                      :1:tFiles(p_index).nbFormats);
    endif;

    //if found returns index's
    if index > 0;
      return index;
    endif;

    //allocates records formats array if not exists
    if tFiles(p_index).nbFormats = 0;
      ptr_formats = %alloc(%size(tFormats) * ALLOC_FORMATS);
      tFiles(p_index).ptrTFormats = ptr_formats;
      tFiles(p_index).allocFormats = ALLOC_FORMATS;
    //increases array size for add to files array if necessary
    elseif (tFiles(p_index).nbFormats + 1) > tFiles(p_index).allocFormats;
      tFiles(p_index).allocFormats += INCR_FORMATS;
      ptr_formats = %realloc(tFiles(p_index).ptrTFormats
                          :%size(tFormats) * tFiles(p_index).allocFormats);
      tFiles(p_index).ptrTFormats = ptr_formats;
    endif;

    //add record format to array
    tFiles(p_index).nbFormats += 1;
    index = tFiles(p_index).nbFormats;
    clear tFormats(index);
    tFormats(index).name = p_name;

    return index;
  END-PROC; 

Can be part of a service program