www.justiceforchandra.com Forum Index www.justiceforchandra.com
Justice for Chandra Levy and missing women
 
 FAQFAQ   SearchSearch   MemberlistMemberlist   UsergroupsUsergroups   RegisterRegister 
 ProfileProfile   Log in to check your private messagesLog in to check your private messages   Log inLog in 

rdwrites RDWGET iSeries Scripted Web Retrieval
Goto page Previous  1, 2, 3  Next
 
Post new topic   Reply to topic    www.justiceforchandra.com Forum Index -> www.rdwrites.com forum (part of www.justiceforchandra.com)
View previous topic :: View next topic  
Author Message
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Mon Mar 19, 2012 11:51 pm    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subroutine: qualify char for field add
       //**************************************************************
         begsr chkFieldAdd;

           charAdded = *off;

           if (%scan(evalchar: rdwLower) > *zeros)
             or (%scan(evalchar: rdwUpper) > *zeros)
             or (%scan(evalchar: rdwNumbers) > *zeros)
             or evalchar = Underline;
             // add text to fld array
             if fldidx < fldlen;
               fldidx += 1;
               fldary(fldidx) = evalchar;
               scridx += 1;
               charpos += 1;
               charAdded = *on;
             else;
               // field exceeds rdwField length parse error
               prmErrCode = 'RDW0021';
               exsr parseScriptErr;
             endif;
           endif;

         endsr;

       //**************************************************************
       //  Subroutine: qualify char for function
       //**************************************************************
         begsr chkFuncAdd;

           charAdded = *off;

           if (%scan(evalchar: rdwLower) > *zeros)
             or (%scan(evalchar: rdwUpper) > *zeros)
             or (%scan(evalchar: rdwNumbers) > *zeros)
             or evalchar = Underline
             or evalchar = Colon
             or evalchar = LeftParen
             or evalchar = RightParen;
             // add text to fnc array
             if fncidx < fnclen;
               fncidx += 1;
               fncary(fncidx) = evalchar;
               charAdded = *on;
             else;
               // field exceeds rdwField length parse error
               prmErrCode = 'RDW0021';
               exsr parseScriptErr;
             endif;
           endif;

         endsr;

       //**************************************************************
       //  Subroutine: add char to string
       //**************************************************************
         begsr chkStringAdd;

           charAdded = *off;

           // add char to string array
           if stridx < strlen;
             stridx += 1;
             strary(stridx) = scrary(scridx);
             scridx += 1;
             charpos += 1;
             charAdded = *on;
           else;
             // field exceeds rdwOperand length parse error
             prmErrCode = 'RDW0032';
             exsr parseScriptErr;
           endif;

         endsr;

       //**************************************************************
       //  Subroutine: add char to args
       //**************************************************************
         begsr chkArgsAdd;

           charAdded = *off;

           // add char to args array
           if argidx < arglen;
             argidx += 1;
             argary(argidx) = scrary(scridx);
             scridx += 1;
             charpos += 1;
             charAdded = *on;
           else;
             // field exceeds rdwOperand length parse error
             prmErrCode = 'RDW0032';
             exsr parseScriptErr;
           endif;

         endsr;

       //**************************************************************
       //  Subroutine: load next Script buffer
       //**************************************************************
         begsr loadScrData;

           select;
             when scrEOF = *on;
               // no more data - check for error and leave
               if linePhase > OpcodePhase;
                 // unexpected EOF parse error
                 prmErrCode = 'RDW0022';
                 exsr parseScriptErr;
               else;
                 readState = ExitState;
               endif;

             other;
               readlen = rdwReadIFS(prmScriptHnd: readPtr: requestLen);
               if readlen < requestLen;
                 scrEOF = *on;
               endif;
               scrlen = readlen;
               scridx = 1;
           endsl;

         endsr;
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Mon Mar 19, 2012 11:53 pm    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subroutine: parse white space to EOL
       //**************************************************************
         begsr parseWhite;

           dow readState = SeekWhite;
             dow scridx <= scrlen;
               evalchar = scrary(scridx);
               select;
                 when evalchar = rdwCR
                   or evalchar = rdwLF
                   or evalchar = Slash;
                   readState = SeekEOL;
                   linePhase = EOLPhase;
                   leavesr;

                 when evalchar <= nonbrkBlank;
                   scridx += 1;
                   charpos += 1;

                 other;
                   // unexpected special character parse error
                   prmErrCode = 'RDW0020';
                   exsr parseScriptErr;
                   leavesr;
               endsl;
             enddo;

             if readState <> ExitState;
               exsr loadScrData;
             endif;
           enddo;

         endsr;

       //**************************************************************
       //  Subroutine: parse to EOL
       //**************************************************************
         begsr parseEOL;

           dow readState = SeekEOL;
             dow scridx <= scrlen;
               evalchar = scrary(scridx);
               select;
                 when evalchar = rdwCR
                   or evalchar = rdwLF;
                   readState = SeekOpcode;
                   linePhase = StartPhase;
                   leavesr;

                 other;
                   scridx += 1;
                   charpos += 1;
               endsl;
             enddo;

             if readState <> ExitState;
               exsr loadScrData;
             endif;
           enddo;

         endsr;

       //**************************************************************
       //  Subroutine: parse CRLF's
       //**************************************************************
         begsr parseCRLF;

           dow readState <> ExitState;
             dow scridx <= scrlen;
               evalchar = scrary(scridx);
               select;
                 when evalchar = rdwCR;
                   scridx += 1;

                 when evalchar = rdwLF;
                   linepos += 1;
                   charpos = *zeros;
                   scridx += 1;

                 other;
                   // have parsed to beginning of line - evaluate
                   leavesr;
               endsl;
             enddo;

             if readState <> ExitState;
               exsr loadScrData;
             endif;
           enddo;

         endsr;

       //**************************************************************
       //  Subroutine: audit parsing error and end script parsing
       //**************************************************************
         begsr parseScriptErr;

           isError = *on;
           prmErrPos = charpos;
           lineErrPos = 'line ' + %char(linepos);

           setRDWvar(prmScript:
                     prmGetUser:
                     'PARSEERR':
                     scrData);

           audParseErr(prmScript:
                       prmErrCode:
                       lineErrPos:
                       prmErrPos);

           readState = ExitState;

         endsr;
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Mon Mar 19, 2012 11:55 pm    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subroutine: open GetPath file
       //**************************************************************
         begsr openGetPath;

           select;
             when prmGetPath = prmWorkPath;
               exsr openWork;

             other;
               // audit work file not found
               prmErrCode = 'RDW0037';
               isError = audScriptErr(prmScript: prmErrCode);
               readState = ExitState;
           endsl;

         endsr;

       //**************************************************************
       //  Subroutine: open wrkPath file
       //**************************************************************
         begsr openWork;

           %str(%addr(WorkPath): (%len(WorkPath)-1)) = %trimr(prmWorkPath);
           WorkHnd = rdwOpenIFS_RO(WorkPath);
           if (WorkHnd < *zeros);
             // audit work file not found
             prmErrCode = 'RDW0037';
             isError = audScriptErr(prmScript: prmErrCode);
             readState = ExitState;
             leavesr;
           endif;

           exsr loadWrkData;

         endsr;

       //**************************************************************
       //  Subroutine: load next Script buffer
       //**************************************************************
         begsr loadWrkData;

           select;
             when wrkEOF = *on;
               wrkRead = *zeros;

             other;
               wrkRead = rdwReadIFS(WorkHnd: wrkPtr: wrkRequest);
               if wrkRead < wrkRequest;
                 wrkEOF = *on;
               endif;
               wrklen = wrkRead;
               wrkidx = 1;
           endsl;

         endsr;

      /end-free
     p parseScript     e

       //**************************************************************
       //  Subprocedure: chkScriptAry
       //  Purpose:      check that script is not already in stack
       //    If this is a nested script call from a stack that has
       //    already invoked this script, there is no namespace
       //    protection from same scriptname collisions. Architecture
       //    could be enhanced to provide nested level namespace,
       //    but workaround is to copy script and name it Script1,
       //    Script2, etc. for lower level calls of the same script.
       //  Parms:        prmScript    = script name
       //                prmErrCode   = error code
       //  Returns:      isError      = *on if script already in stack
       //**************************************************************
       //
     p chkScriptAry    b
     d chkScriptAry    pi                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmErrCode                         like(rdwErrCode)

       // local fields
     d isError         s                   like(boolean) inz(*off)
     d x               s                   like(curScript)
     d y               s                   like(curScript)

      /free
         curScript += 1;
         if curScript > maxScript;
           isError = *on;
           // max script call level exceeded
           prmErrCode = 'RDW0016';
           return isError;
         endif;

         x = curScript-1;
         for y = x downto 1;
           if scriptary(y) = prmScript;
             isError = *on;
             // script name already in call stack
             prmErrCode = 'RDW0017';
             return isError;
           endif;
         endfor;

         scriptary(curScript) = prmScript;
         return isError;

      /end-free
     p chkScriptAry    e

       //**************************************************************
       //  Subprocedure: rmvScriptAry
       //  Purpose:      pop script from stack
       //  Parms:        prmScript    = script name
       //**************************************************************
       //
     p rmvScriptAry    b
     d rmvScriptAry    pi
     d  prmScript                          like(rdwScript) const

      /free
         scriptary(curScript) = *blanks;
         curScript -= 1;

      /end-free
     p rmvScriptAry    e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:32 am    Post subject: Reply with quote

RDWGETSV.RPGLE
Code:

      *****************************************************************
      *               RDWGET iSeries Scripted Web Retrieval
      *
      *  Service Program RDWGETSV
      *****************************************************************
     h  nomain
      /copy rdwgetsrc,rdwgeth
     h bnddir('HTTPAPI')

      *****************************************************************
      * File Specifications
      *****************************************************************
     frdwgetvar uf a e           k disk    usropn
     frdwgettrn uf a e           k disk    usropn
     frdwgetaud o    e             disk    usropn

      *****************************************************************
      * Prototype Definitions
      *****************************************************************
      /copy rdwgetsrc,rdwritespr
      /copy rdwgetsrc,rdwgetpr
      /copy rdwgetsrc,rdwapipr
      /define webforms
      /copy libhttp/qrpglesrc,httpapi_h
      /copy libhttp/qrpglesrc,ifsio_h

       //**************************************************************
       //  Subprocedure: setRDWvar
       //  Purpose:      sets var value to parm by parm key
       //                adds var if not exist
       //  Parms:        prmScript    = script
       //                prmUser      = script user
       //                prmKey       = var key
       //                prmValue     = var value
       //  Returns:      iserror      = *on if error
       //**************************************************************
       //
     p setRDWvar       b                   export
     d setRDWvar       pi              n
     d  prmScript                          like(varscr) const
     d  prmUser                            like(varuser) const
     d  prmKey                             like(varkey) const
     d  prmValue                           like(varval) const

       // local fields
     d isError         s                   like(boolean)

      /free
         isError = *on;

         open(e) rdwgetvar;
         if %error;
           return isError;
         endif;

         chain(e) (prmScript: prmUser: prmKey) rdwgetvar;
         if %error;
           return isError;
         endif;

         varval = prmValue;
         if %found(rdwgetvar);
           update(e) getvarr;
           if %error;
             return isError;
           endif;
         else;
           varscr = prmScript;
           varuser = prmUser;
           varkey = prmKey;
           write(e) getvarr;
           if %error;
             return isError;
           endif;
         endif;

         close(e) rdwgetvar;
         isError = *off;
         return isError;

      /end-free
     p setRDWvar       e

       //**************************************************************
       //  Subprocedure: getRDWvar
       //  Purpose:      gets var value by parm key
       //  Parms:        prmScript    = script
       //                prmUser      = script user
       //                prmKey       = var key
       //  Returns:      prmValue     = var value
       //**************************************************************
       //
     p getRDWvar       b                   export
     d getRDWvar       pi                  like(varval)
     d  prmScript                          like(varscr) const
     d  prmUser                            like(varuser) const
     d  prmKey                             like(varkey) const

       // local fields
     d prmValue        s                   like(varval)

      /free
         prmValue = *blanks;

         open(e) rdwgetvar;
         if %error;
           return prmValue;
         endif;

         chain(ne) (prmScript: prmUser: prmKey) rdwgetvar;
         if %found(rdwgetvar);
           prmValue = varval;
         endif;

         close(e) rdwgetvar;
         return prmValue;

      /end-free
     p getRDWvar       e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:34 am    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subprocedure: rdwBldPath
       //  Purpose:      build null terminated path from standard path,
       //    optional subdirectory, and optional filename.
       //  Parms:        prmPath      = directory path
       //                prmSubdir    = optional subdirectory path
       //                prmFile      = optional file name
       //                prmScript    = script name
       //                prmGetUser   = getvar user
       //                prmEvalled   = optionally substituted path value
       //                prmErrPos    = char position of error
       //  Returns:      isError      = *on if error
       //**************************************************************
       //
     p rdwBldPath      b                   export
     d rdwBldPath      pi                  like(boolean)
     d  prmPath                            like(rdwPath) const
     d  prmSubDir                          like(rdwSubDir) const
     d  prmFile                            like(rdwFile) const
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmEvalled                         like(rdwPath)
     d  prmErrPos                          like(charloc)

       // local fields
     d isError         s                   like(boolean) inz(*off)
     d wrkPath         s                   like(rdwPath)

      /free
         isError = rdwEvalPath(prmPath:
                               prmScript:
                               prmGetUser:
                               prmEvalled:
                               prmErrPos);

         if isError = *on;
           return IsError;
         endif;

         wrkPath = prmEvalled;

         if prmSubDir <> *blanks;
           isError = rdwEvalPath(prmSubDir:
                                 prmScript:
                                 prmGetUser:
                                 prmEvalled:
                                 prmErrPos);

           if prmEvalled <> *blanks;
             wrkPath = %trimr(wrkPath) + prmEvalled;
           endif;
           if isError = *on;
             prmEvalled = wrkPath;
             return IsError;
           endif;
         endif;

         if prmFile <> *blanks;
           isError = rdwEvalPath(prmFile:
                                 prmScript:
                                 prmGetUser:
                                 prmEvalled:
                                 prmErrPos);

           if prmEvalled <> *blanks;
             wrkPath = %trimr(wrkPath) + prmEvalled;
           endif;
         endif;

         prmEvalled = wrkPath;
         return isError;

      /end-free
     p rdwBldPath      e

       //**************************************************************
       //  Subprocedure: rdwEvalPath
       //  Purpose:      substitute and return trim eval path first blank
       //  Parms:        prmEval      = path to evaluate
       //                prmScript    = script name
       //                prmGetUser   = getVar user
       //                prmEvalled   = optionally substituted path value
       //                prmErrPos    = char position of error
       //  Returns:      isError      = *on if error
       //**************************************************************
       //
     p rdwEvalPath     b                   export
     d rdwEvalPath     pi                  like(boolean)
     d  prmEval                            like(rdwPath) const
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmEvalled                         like(rdwPath)
     d  prmErrPos                          like(charloc)

       // local fields
     d                 ds
     d  wrkData                            like(prmEval)
     d  wrkary                             like(charval) dim(%size(wrkData))
     d                                     overlay(wrkData: 1)
     d wrklen          s                   like(charloc) inz(%size(wrkData))
     d wrkidx          s                   like(charloc) inz(1)

     d                 ds
     d  outData                            like(prmEval)
     d  outary                             like(charval) dim(%size(outData))
     d                                     overlay(outData: 1)
     d outlen          s                   like(charloc) inz(%size(outData))
     d outidx          s                   like(charloc) inz(*zeros)

     d isError         s                   like(boolean) inz(*off)
     d evalchar        s                   like(charval)

      /free
         wrkData = prmEval;
         dow wrkidx <= wrklen;
           evalchar = wrkary(wrkidx);
           select;
             when evalchar <= nonbrkBlank;
               // end of eval string
               leave;

             other;
               // add text to out array
               if outidx < outlen;
                 outidx += 1;
                 outary(outidx) = wrkary(wrkidx);
                 wrkidx += 1;
               else;
                 prmErrPos = wrkidx;
                 isError = *on;
                 setRDWvar(prmScript:
                           prmGetUser:
                           'PARSEERR':
                           prmEval);
                 leave;
               endif;
           endsl;
         enddo;

         prmEvalled = outData;
         return isError;

      /end-free
     p rdwEvalPath     e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:39 am    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subprocedure: rdwGetURL
       //  Purpose:      get URL and store to wrkPath file
       //  Parms:        prmScript    = script name
       //                prmGetUser   = getVar user
       //                prmWorkPath  = RDWGET script work path
       //                prmOprData   = URL
       //  Returns:      isError      = *on if error
       //**************************************************************
       //
     p rdwGetURL       b                   export
     d rdwGetURL       pi                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmWorkPath                        like(rdwPath) const
     d  prmOprData                         like(rdwOperand) const

       // local fields
     d isError         s                   like(boolean) inz(*off)
     d url             s                   like(rdwOperand)
     d rc              s                   like(int32)

      /free
         rc = *zeros;
         geterrmsg = *blanks;
         url = prmOprData;

         dou rc <> 302;
           rc = http_url_get(%trimr(url):
                        prmWorkPath);

           if rc = 302;
             url = http_redir_loc;
           endif;
         enddo;

         if rc <> getSUCCESS;
           geterrmsg = http_error;
           auditScript(prmScript:
                       'GETERR':
                       geterrmsg);

           setRDWvar(prmScript:
                     prmGetUser:
                     'GETERR':
                     prmOprData);

           isError = *on;
         endif;

         return isError;

      /end-free
     p rdwGetURL       e

       //**************************************************************
       //  Subprocedure: rdwPostURL
       //  Purpose:      post form to URL and store to wrkPath file
       //  Parms:        prmScript    = script name
       //                prmGetUser   = getVar user
       //                prmWorkPath  = RDWGET script work path
       //                prmSetFormAry= form variables
       //                prmSetFormVal= form variable values
       //                prmSetFormIdx= form variables index
       //                prmOprData   = URL
       //  Returns:      isError      = *on if error
       //**************************************************************
       //
     p rdwPostURL      b                   export
     d rdwPostURL      pi                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmWorkPath                        like(rdwPath) const
     d  prmSetFormAry                      like(rdwCmpBuf) const
     d                                     dim(rdwFormMax)
     d  prmSetFormVal                      like(rdwPath) const
     d                                     dim(rdwFormMax)
     d  prmSetFormIdx                      like(rdwState) const
     d  prmOprData                         like(rdwOperand) const

       // local fields
     d isError         s                   like(boolean) inz(*off)
     d rc              s                   like(int32)
     d Form            s                   like(WEBFORM)
     d FormPtr         s                   like(basePtr)
     d dataSize        s                   like(int32)
     d x               s                   like(prmSetFormIdx)

      /free
         rc = *zeros;
         geterrmsg = *blanks;

         Form = WEBFORM_open;

         for x = 1 to prmSetFormIdx;
           callp WEBFORM_SetVar(Form: %trimr(prmSetFormAry(x)):
                                      %trimr(prmSetFormVal(x)));
         endfor;

         callp WEBFORM_postData(Form: FormPtr: dataSize);

         rc = http_url_post(
                %trimr(prmOprData)
                :FormPtr
                :dataSize
                :prmWorkPath
                :HTTP_TIMEOUT
                :HTTP_USERAGENT
                :'application/x-www-form-urlencoded');

         if rc = 302;
           isError = rdwGetURL(prmScript:
                               prmGetUser:
                               prmWorkPath:
                               http_redir_loc);
         endif;

         callp WEBFORM_close(Form);
         return isError;

      /end-free
     p rdwPostURL      e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:42 am    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subprocedure: audParseErr
       //  Purpose:      audit error message for parsing
       //                Error message contains loc of error of line.
       //  Parms:        prmScript    = script name
       //                prmErrCode   = error code
       //                prmErrLine   = line position of error
       //                prmErrPos    = char position of error
       //  Returns:      isLR         = *on if fatal error
       //**************************************************************
       //
     p audParseErr     b                   export
     d audParseErr     pi                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmErrCode                         like(rdwErrCode) const
     d  prmErrLine                         like(isysobj) const
     d  prmErrPos                          like(charloc) const

       // local fields
     d isLR            s                   like(boolean)
     d prmMsgDta       s                   like(rdwMsgDta)
     d prmMsgRet       s                   like(rdwMsgRet)
     d prmAudMsg       s                   like(rdwAudMsg)
     d tmpfld          s              2a
     d tmplen          s                   like(charloc)

      /free
         tmplen = %len(%char(prmErrPos));
         select;
           when tmplen = 1;
             tmpfld = X'0002';

           when tmplen = 2;
             tmpfld = X'0003';

           when tmplen = 3;
             tmpfld = X'0004';

           other;
             tmpfld = X'0005';
         endsl;

         prmMsgDta = tmpfld +
                     %char(prmErrPos) +
                     Blank +
                     (X'000A') +
                     (%trimr(prmErrLine));
         callp rdwRtvMsgi(msgFile: prmErrCode: prmMsgDta: prmMsgRet);
         prmAudMsg = prmMsgRet;
         auditScript(prmScript:
                     prmErrCode:
                     prmAudMsg);
         isLR = *on;
         return isLR;

      /end-free
     p audParseErr     e

       //**************************************************************
       //  Subprocedure: audScript
       //  Purpose:      audit message for script.
       //                Message contains parm for script name.
       //  Parms:        prmScript    = script name
       //                prmMsgCode   = message code
       //**************************************************************
       //
     p audScript       b                   export
     d audScript       pi
     d  prmScript                          like(rdwScript) const
     d  prmMsgCode                         like(rdwErrCode) const

       // local fields
     d prmMsgRet       s                   like(rdwMsgRet)
     d prmAudMsg       s                   like(rdwAudMsg)

      /free
         callp rdwRtvMsgi(msgFile: prmMsgCode: prmScript: prmMsgRet);
         prmAudMsg = prmMsgRet;
         auditScript(prmScript:
                     prmMsgCode:
                     prmAudMsg);

      /end-free
     p audScript       e

       //**************************************************************
       //  Subprocedure: audScriptErr
       //  Purpose:      audit error message for script.
       //                Error message contains parm for script name.
       //  Parms:        prmScript    = script name
       //                prmErrCode   = error code
       //  Returns:      isLR         = *on if fatal error
       //**************************************************************
       //
     p audScriptErr    b                   export
     d audScriptErr    pi                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmErrCode                         like(rdwErrCode) const

       // local fields
     d isLR            s                   like(boolean)
     d prmMsgRet       s                   like(rdwMsgRet)
     d prmAudMsg       s                   like(rdwAudMsg)

      /free
         callp rdwRtvMsgi(msgFile: prmErrCode: prmScript: prmMsgRet);
         prmAudMsg = prmMsgRet;
         auditScript(prmScript:
                     prmErrCode:
                     prmAudMsg);
         isLR = *on;
         return isLR;

      /end-free
     p audScriptErr    e

       //**************************************************************
       //  Subprocedure: auditScript
       //  Purpose:      audit file for Script processing messages.
       //                Errors at any level or completion of top level script.
       //  Parms:        prmKey       = RDWGET script key
       //                prmCode      = audit code
       //                prmMsg       = audit message
       //**************************************************************
       //
     p auditScript     b                   export
     d auditScript     pi
     d  prmKey                             like(rdwScript) const
     d  prmCode                            like(rdwErrCode) const
     d  prmMsg                             like(rdwAudMsg) const

       // local fields
     d prmFile         c                   'RDWGETAUD'

      /free
         open(e) rdwgetaud;
         if %error;
           return;
         endif;

         audtrn = rdwGetTran(prmFile);
         audkey = prmKey;
         rdwJobName(audjob:
                    auduser:
                    audjobnbr);
         audstmp = %timestamp();
         audcode = prmCode;
         audmsg = prmMsg;

         write(e) getaudr;
         close(e) rdwgetaud;

      /end-free
     p auditScript     e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:46 am    Post subject: Reply with quote

Code:

       //**************************************************************
       //  Subprocedure: rdwGetTran
       //  Purpose:      get next tran number from tran control file by key
       //  Parms:        prmFile      = RDWGET file tran key
       //  Returns:      prmTrn       = tran number
       //**************************************************************
       //
     p rdwgetTran      b                   export
     d rdwgetTran      pi                  like(rdwTrnnbr)
     d  prmFile                            like(rdwTrnkey) const

       // local fields
     d prmTrn          s                   like(rdwTrnNbr)

      /free
         prmTrn = *zeros;

         open(e) rdwgettrn;
         if %error;
           return prmTrn;
         endif;

         chain(e) (prmFile) rdwgettrn;
         if not %found(rdwgettrn);
           // create tran key
           trnkey = prmFile;
           trnnbr = 1;
           write(e) gettrnr;
           if not %error;
             prmTrn = trnnbr;
           endif;
         else;
           // inc tran key
           monitor;
             trnnbr += 1;
           on-error;
             trnnbr = 1;
           endmon;
           update(e) gettrnr;
           if not %error;
             prmTrn = trnnbr;
           endif;
         endif;

         close(e) rdwgettrn;
         return prmTrn;

      /end-free
     p rdwGetTran      e

       //**************************************************************
       //  Subprocedure: rdwOpenIFS_RO
       //  Purpose:      procedure to open IFS file read only
       //  Parms:        prmPathNul   = null terminated path ptr
       //  Returns:      prmFileHnd   = file handle
       //**************************************************************
       //
     p rdwOpenIFS_RO   b                   export
     d rdwOpenIFS_RO   pi                  like(int32)
     d  prmPathNul                         like(rdwWrkPath) const

      /free

         return open(prmPathNul: O_RDONLY + O_TEXTDATA);

      /end-free
     p rdwOpenIFS_RO   e

       //**************************************************************
       //  Subprocedure: rdwReadIFS
       //  Purpose:      procedure to read IFS file
       //  Parms:        prmFileHnd   = file handle
       //                prmBufPtr    = read buffer ptr
       //                prmRequest   = requested read length
       //  Returns:      prmRead      = read length
       //**************************************************************
       //
     p rdwReadIFS      b                   export
     d rdwReadIFS      pi                  like(int32)
     d  prmFileHnd                         like(int32) const
     d  prmBufPtr                          like(basePtr) const
     d  prmRequest                         like(uint32) const

      /free

         return read(prmFileHnd: prmBufPtr: prmRequest);

      /end-free
     p rdwReadIFS      e

       //**************************************************************
       //  Subprocedure: rdwCloseIFS
       //  Purpose:      procedure to close IFS file
       //  Parms:        prmFileHnd   = file handle
       //  Returns:      status       = int status
       //**************************************************************
       //
     p rdwCloseIFS     b                   export
     d rdwCloseIFS     pi                  like(int32)
     d  prmFileHnd                         like(int32) const

      /free

         return closef(prmFileHnd);

      /end-free
     p rdwCloseIFS     e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:51 am    Post subject: Reply with quote

RDWAPISV.RPGLE
Code:

      *****************************************************************
      *               RDWGET iSeries Scripted Web Retrieval
      *
      *  Service Program RDWAPISV
      *****************************************************************
     h  nomain
      /copy rdwgetsrc,rdwgeth

      *****************************************************************
      * Prototype Definitions
      *****************************************************************
      /copy rdwgetsrc,rdwritespr
      /copy rdwgetsrc,rdwapipr
      /copy qsysinc/qrpglesrc,qusrjobi

       //**************************************************************
       //  Subprocedure: rdwCmd
       //  Purpose:      execute passed CL command
       //  Parms:        prmCmd       = CL command string
       //  Returns:      isError      = *on if error
       //**************************************************************
       //
     p rdwCmd          b                   export
     d rdwCmd          pi                  like(boolean)
     d  prmCmd                     1024a   const

     d qcmdexc         pr                  extpgm('QCMDEXC')
     d  prmCmd                     1024a   const
     d  prmLen                       15p 5 const

       // local fields
     d isError         s                   like(boolean) inz(*off)

      /free
         monitor;
           qcmdexc(%subst(prmCmd:1:%len(prmCmd)):%len(prmCmd));
         on-error;
           isError = *on;
         endmon;

         return isError;

      /end-free
     p rdwCmd          e

       //**************************************************************
       //  Subprocedure: rdwJobUser
       //  Purpose:      retrieve job user with QUSRJOBI API
       //  Returns:      prmUser      = Job user
       //**************************************************************
       //
     p rdwJobUser      b                   export
     d rdwJobUser      pi                  like(isysobj)

       // local fields
     d  prmJob         s                   like(isysobj)
     d  prmUser        s                   like(isysobj)
     d  prmJobNbr      s                   like(rdwJobNbr)

      /free
         rdwJobName(prmJob:
                    prmUser:
                    prmJobNbr);

         return prmUser;

      /end-free
     p rdwJobUser      e

       //**************************************************************
       //  Subprocedure: rdwJobName
       //  Purpose:      retrieve job name with QUSRJOBI API
       //  Parms:        prmJob       = Job name
       //                prmUser      = Job user
       //                prmNbr       = Job number
       //**************************************************************
       //
     p rdwJobName      b                   export
     d rdwJobName      pi
     d  prmJob                             like(isysobj)
     d  prmUser                            like(isysobj)
     d  prmNbr                             like(rdwJobNbr)

      /free
         qusbprv = *zeros;

         RtvJobI(QUSI030000:
                 %size(QUSI030000):
                 'JOBI0300':
                 '*':
                 ' ':
                 qusec);

         prmJob = qusjn04;
         prmUser = qusun04;
         prmNbr = qusjnbr04;

      /end-free
     p rdwJobName      e
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 12:56 am    Post subject: Reply with quote

RDWGETH.RPGLE
Code:

      *****************************************************************
      *               RDWGET iSeries Scripted Web Retrieval
      *
      *  Copy file RDWGETH
      *****************************************************************
      * H specs
     h optimize(*NONE) decedit(*JOBRUN) truncnbr(*NO)
     h debug option(*srcstmt:*nodebugio)
     h bnddir('RDWGET')


RDWRITESPR.RPGLE
Code:

      *****************************************************************
      *               RDWRITES Prototype Definitions
      *
      *  Copy file RDWRITESPR
      *****************************************************************

      *****************************************************************
      * Data Structure Declaration
      *****************************************************************
      * system program feedback area
     d psds           sds           429
     d  pgmname                      10a
     d  pgmlib                81     90a
     d  jobname              244    253a
     d  usrname                      10a
     d  jobnbr                        6s 0

      * IBM API error data structure
     d qusec           ds
     d  qusbprv                            like(int32) inz(%size(qusec))
     d  qusbavl                            like(int32) inz(0)
     d  qusei                         7a
     d                                1a
     d  msgdata                     500a

      *****************************************************************
      * Stand Alone Fields Declaration
      *****************************************************************
      * like prototypes
     d boolean         s               n
     d int32           s             10i 0
     d uint32          s             10u 0
     d basePtr         s               *
     d charval         s              1a
     d charloc         s              5  0

      * like constants
     d isysobj         s             10a
     d rdwJobNbr       s              6a

      * constants
     d rdwNull         c                   const(X'00')
     d rdwCR           c                   const(X'0D')
     d rdwLF           c                   const(X'25')
     d nonbrkBlank     c                   const(X'41')
     d Tick            c                   const(X'7D')
     d Ampersand       c                   const('&')
     d Blank           c                   const(' ')
     d Colon           c                   const(':')
     d rdwEqual        c                   const('=')
     d LeftParen       c                   const('(')
     d Percent         c                   const('%')
     d rdwPlus         c                   const('+')
     d Quote           c                   const('"')
     d RightParen      c                   const(')')
     d Slash           c                   const('/')
     d Star            c                   const('*')
     d Underline       c                   const('_')
     d rdwUpper        c                   const('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
     d rdwLower        c                   const('abcdefghijklmnopqrstuvwxyz')
     d rdwNumbers      c                   const('0123456789')
     d HTMLbreak       c                   const('<br>')
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 1:02 am    Post subject: Reply with quote

RDWGETPR.RPGLE
Code:

      *****************************************************************
      *               RDWGET iSeries Scripted Web Retrieval
      *
      *  Copy file RDWGETPR
      *****************************************************************

      *****************************************************************
      * Prototype: rdwRtvMsgi
      *****************************************************************
     d rdwRtvMsgi      pr                  extpgm('RDWRTVMSGI')
     d  msgf                               like(isysobj) const
     d  msgid                              like(rdwErrCode) const
     d  msgdta                             like(rdwMsgDta) const
     d  msgret                             like(rdwMsgRet)

      *****************************************************************
      * Subprocedure: setRDWvar
      *****************************************************************
     d setRDWvar       pr                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmUser                            like(rdwUser) const
     d  prmKey                             like(rdwVarKey) const
     d  prmValue                           like(rdwVarVal) const

      *****************************************************************
      * Subprocedure: getRDWvar
      *****************************************************************
     d getRDWvar       pr                  like(rdwVarVal)
     d  prmScript                          like(rdwScript) const
     d  prmUser                            like(rdwUser) const
     d  prmKey                             like(rdwVarKey) const

      *****************************************************************
      * Subprocedure: rdwBldPath
      *****************************************************************
     d rdwBldPath      pr                  like(boolean)
     d  prmPath                            like(rdwPath) const
     d  prmSubDir                          like(rdwSubDir) const
     d  prmFile                            like(rdwFile) const
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmEvalled                         like(rdwPath)
     d  prmErrPos                          like(charloc)

      *****************************************************************
      * Subprocedure: rdwEvalPath
      *****************************************************************
     d rdwEvalPath     pr                  like(boolean)
     d  prmEval                            like(rdwPath) const
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmEvalled                         like(rdwPath)
     d  prmErrPos                          like(charloc)

      *****************************************************************
      * Subprocedure: rdwGetURL
      *****************************************************************
     d rdwGetURL       pr                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmWorkPath                        like(rdwPath) const
     d  prmOprData                         like(rdwOperand) const

      *****************************************************************
      * Subprocedure: rdwPostURL
      *****************************************************************
     d rdwPostURL      pr                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmGetUser                         like(rdwUser) const
     d  prmWorkPath                        like(rdwPath) const
     d  prmSetFormAry                      like(rdwCmpBuf) const
     d                                     dim(rdwFormMax)
     d  prmSetFormVal                      like(rdwPath) const
     d                                     dim(rdwFormMax)
     d  prmSetFormIdx                      like(rdwState) const
     d  prmOprData                         like(rdwOperand) const

      *****************************************************************
      * Subprocedure: audParseErr
      *****************************************************************
     d audParseErr     pr                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmErrCode                         like(rdwErrCode) const
     d  prmErrLine                         like(isysobj) const
     d  prmErrPos                          like(charloc) const

      *****************************************************************
      * Subprocedure: audScript
      *****************************************************************
     d audScript       pr
     d  prmScript                          like(rdwScript) const
     d  prmMsgCode                         like(rdwErrCode) const

      *****************************************************************
      * Subprocedure: audScriptErr
      *****************************************************************
     d audScriptErr    pr                  like(boolean)
     d  prmScript                          like(rdwScript) const
     d  prmErrCode                         like(rdwErrCode) const

      *****************************************************************
      * Subprocedure: auditScript
      *****************************************************************
     d auditScript     pr
     d  prmScript                          like(rdwScript) const
     d  prmCode                            like(rdwErrCode) const
     d  prmMsg                             like(rdwAudMsg) const

      *****************************************************************
      * Subprocedure: rdwGetTran
      *****************************************************************
     d rdwGetTran      pr                  like(rdwTrnNbr)
     d  keyTran                            like(rdwTrnKey) const

      *****************************************************************
      * Subprocedure: rdwOpenIFS_RO
      *****************************************************************
     d rdwOpenIFS_RO   pr                  like(int32)
     d  prmPathNul                         like(rdwWrkPath) const

      *****************************************************************
      * Subprocedure: rdwReadIFS
      *****************************************************************
     d rdwReadIFS      pr                  like(int32)
     d  prmFileHnd                         like(int32) const
     d  prmBufPtr                          like(basePtr) const
     d  prmRequest                         like(uint32) const

      *****************************************************************
      * Subprocedure: rdwCloseIFS
      *****************************************************************
     d rdwCloseIFS     pr                  like(int32)
     d  prmFileHnd                         like(int32) const

      *****************************************************************
      * Data Structure Declaration
      *****************************************************************
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 1:03 am    Post subject: Reply with quote

Code:

      *****************************************************************
      * Stand Alone Fields Declaration
      *****************************************************************
     d rdwScript       s             10a
     d rdwUser         s             14a
     d rdwVarKey       s              8a
     d rdwVarVal       s           1024a
     d rdwPath         s            120a
     d rdwSubdir       s             40a
     d rdwFile         s             40a
     d rdwMsgDta       s             32a
     d rdwMsgRet       s            132a
     d rdwAudMsg       s            256a
     d rdwTrnKey       s             10a
     d rdwTrnNbr       s              9  0
     d rdwState        s              3  0
     d rdwErrCode      s              7a
     d getErrCode      s                   like(int32)
     d getErrMsg       s             52a
     d nullPath        s             +1    like(rdwPath)
     d rdwWrkPath      s            121a   varying
     d rdwFileBuf      s           1024a
     d rdwField        s             14a
     d rdwOperand      s           1024a
     d rdwCmpBuf       s             32a

     d* Constants
     d SeekOpcode      c                   const(1)
     d SeekResult      c                   const(2)
     d SeekEqual       c                   const(3)
     d SeekOperand     c                   const(4)
     d SeekWhite       c                   const(6)
     d SeekEOL         c                   const(99)
     d ExitState       c                   const(999)
     d StartPhase      c                   const(1)
     d OpcodePhase     c                   const(2)
     d ResultPhase     c                   const(3)
     d FieldPhase      c                   const(4)
     d EqualityPhase   c                   const(5)
     d OperandPhase    c                   const(6)
     d CommentPhase    c                   const(7)
     d StringPhase     c                   const(8)
     d FuncPhase       c                   const(9)
     d ValuePhase      c                   const(10)
     d ArgsPhase       c                   const(11)
     d SourcePhase     c                   const(12)
     d ExecPhase       c                   const(13)
     d WhitePhase      c                   const(14)
     d ContinuePhase   c                   const(98)
     d EOLPhase        c                   const(99)
     d rdwFormMax      c                   const(99)
     d getSUCCESS      c                   const(1)
     d msgFile         c                   'RDWMSGF'
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 1:05 am    Post subject: Reply with quote

RDWAPIPR.RPGLE
Code:

      *****************************************************************
      *               RDWGET iSeries Scripted Web Retrieval
      *
      *  Copy file RDWAPIPR
      *****************************************************************

      *****************************************************************
       // API prototypes
      *****************************************************************
      * Prototype: RtvJobI
      *****************************************************************
     d RtvJobI         pr                  extpgm('QUSRJOBI')
     d  RcvVar                        1a   options(*varsize)
     d  LenRcvVar                          like(int32) const
     d  RcvVarFmt                     8a   const
     d  JobName                      26a   const
     d  IntJobID                     16a   const
     d  Qusec                              likeds(qusec) options(*nopass)
     d  Reset                         1a   const options(*nopass)

      *****************************************************************
       // RDWAPISV prototypes
      *****************************************************************
      * Subprocedure: rdwCmd
      *****************************************************************
     d rdwCmd          pr                  like(boolean)
     d  prmCmd                     1024    const

      *****************************************************************
      * Subprocedure: rdwJobUser
      *****************************************************************
     d rdwJobUser      pr                  like(isysobj)

      *****************************************************************
      * Subprocedure: rdwJobName
      *****************************************************************
     d rdwJobName      pr
     d  prmJob                             like(isysobj)
     d  prmUser                            like(isysobj)
     d  prmNbr                             like(rdwJobNbr)

      *****************************************************************
      * Data Structure Declaration
      *****************************************************************

      *****************************************************************
      * Stand Alone Fields Declaration
      *****************************************************************
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 1:07 am    Post subject: Reply with quote

CGIDEV2PR.RPGLE
Code:

      *****************************************************************
      *               CGIDEV2 Prototype Definitions
      *
      *  Copy file CGIDEV2PR
      *****************************************************************
      * D specs
      /copy cgidev2/qrpglesrc,prototypeb

      * indicators for getHtmlIfsMult subprocedure
     d IfsMultIndicators...
     d                 ds
     d  NoErrors                           like(boolean)
     d  NameTooLong                        like(boolean)
     d  NotAccessible                      like(boolean)
     d  NoFilesUsable                      like(boolean)
     d  DupSections                        like(boolean)
     d  FileIsEmpty                        like(boolean)

      *****************************************************************
      * Stand Alone Fields Declaration
      *****************************************************************

      * program timing variable
     d sec             s             15p 6

      * number of variables
     d nbrVars         s                   like(int32)

      * string variables
     d htmlMsgStr      s           1000a   varying

     d savedQueryString...
     d                 s          32767a   varying

      * constants
     d newline         c                   const(X'15')

     d CGIDev2Lib      c                   'CGIDEV2'
     d CGIDev2Html     c                   '/CgidevExtHtml/'
     d htmlHeader      c                   'Content-type: text/html'
     d htmlErrMsg      c                    '<html><body> -
     d                                      <p>An error occurred. -
     d                                      Programmer has been notified. -
     d                                      Please try again later. -
     d                                      </p></body></html>'
Back to top
View user's profile Send private message Send e-mail Visit poster's website
rd



Joined: 13 Sep 2002
Posts: 9241
Location: Jacksonville, FL

PostPosted: Tue Mar 20, 2012 1:09 am    Post subject: Reply with quote

TESTCGIGET.RPGLE
Code:

      *****************************************************************
      *                      RDWGET Testing
      *
      *  Program TESTCGIGET
      *****************************************************************
     h dftactgrp(*no) actgrp('RDWRITES')
     h bnddir('CGIDEV2':'QC2LE':'QUSAPIBD')
      /copy rdwgetsrc,rdwgeth

      *****************************************************************
      * Prototype Definitions
      *****************************************************************
      /copy rdwgetsrc,cgidev2pr
      /copy rdwgetsrc,rdwritespr
      /copy rdwgetsrc,rdwgetpr

      *****************************************************************
      * *Entry Declaration
      *****************************************************************
     d TESTCGIGET      pr
     d TESTCGIGET      pi

      *****************************************************************
      * Data Structure Declaration
      *****************************************************************

      *****************************************************************
      * Stand Alone Fields Declaration
      *****************************************************************
     d testscript      s                   like(rdwScript)
     d testuser        s                   like(rdwUser)
     d testkey         s                   like(rdwVarKey)
     d testvar         s                   like(rdwVarVal)

      *****************************************************************
      * Mainline
      *****************************************************************
      /free
         setNoDebug(*on); // *on for no diagnostics overhead

        // clear the HTML buffer
         if getHtmlBytesBuffered > 0;
           clrHtmlBuffer();
         endif;

        // get input
         nbrVars = zhbGetInput(savedQueryString:qusec);
         select;
           when nbrVars = *zeros;
             testvar = 'Key parm was not included with request';

           other;
             testscript = zhbGetVar('varscript');
             testuser = zhbGetVar('varuser');
             testkey = zhbGetVar('varkey');
             testvar = getRDWvar(testscript: testuser: testkey);
             if testvar = *blanks;
               testvar = 'setRDWvar has not been called with varkey';
             endif;
         endsl;

         htmlMsgStr = htmlHeader + newline + newline +
                      '<html><body><p>' +
                      %trim(testvar) +
                      '</p></body></html>';

         wrtNoSection(%addr(htmlMsgStr)+2:
                      %len(htmlMsgStr));
         wrtSection('*fini');

        // exit program
         exsr exitProgram;

       //**************************************************************
       //  Subroutine: exitProgram
       //**************************************************************
         begsr exitProgram;

           *inlr = *on;
           return;

         endsr;

      /end-free
Back to top
View user's profile Send private message Send e-mail Visit poster's website
Display posts from previous:   
Post new topic   Reply to topic    www.justiceforchandra.com Forum Index -> www.rdwrites.com forum (part of www.justiceforchandra.com) All times are GMT - 4 Hours
Goto page Previous  1, 2, 3  Next
Page 2 of 3

 
Jump to:  
You cannot post new topics in this forum
You cannot reply to topics in this forum
You cannot edit your posts in this forum
You cannot delete your posts in this forum
You cannot vote in polls in this forum


Powered by phpBB © 2001, 2005 phpBB Group