Learn from sources
       Member UPLOAD in CGIDEV2 / QRPGLESRC

       *=========================================================================
       *  RPG ILE PROGRAM CGIDEV2/UPLOAD
       *
       *  It demonstrates the ability of zhbgetinput() to perform file upload
       *
       *  CRTBNDRPG CGIDEV2/UPLOAD DFTACTGRP(*NO) ACTGRP(UPLOAD) DBGVIEW(*SOURCE)
       *
       *=========================================================================
       /copy CGIDEV2/qrpglesrc,hspecs
       /copy CGIDEV2/qrpglesrc,hspecsbnd
       * The following file is used to establish if a client side extension validation is active
      FCHKEXT    if   e             disk    usropn
       * The following file is used to establish the client side valid extensions
      FALWEXT    if   e           k disk    usropn
       * The following file is used to establish if a server side extension validation is active
      FEXITPOINTSif   e           k disk    usropn
       /copy CGIDEV2/qrpglesrc,prototypeb
       /copy CGIDEV2/qrpglesrc,usec
       /copy CGIDEV2/qrpglesrc,variables3
 
       * retrieve system value QDATFMT
      D rtvQDATFMT      pr             3
 
      D ExtHtml         s            500    inz('/cgidev/html/upload.txt')
       * Indicators for GetHtmlIfsMult subprocedure
      D IfsMultIndicators...
      d                 ds
      D  NoErrors                       n
      D  NameTooLong                    n
      D  NotAccessible                  n
      D  NoFilesUsable                  n
      D  DupSections                    n
      D  FileIsEmpty                    n
       *
      D DataLib         c                   'CGIDEV2DT'
      D rrn             s             10u 0
      D YesNo           s              3
      D ActVal1Ind      s               n
      D ActVal2Ind      s               n
      D alwExtensions   s          10000    varying
      D nbrAlwExt       s             10i 0
      D xrequest        s             20
      D serverName      s             50
      D datfmt          s              3
      D stampNow        s               z
      D deleteTime      s               z
      D deleteTimeC     s             26
      D deleteDay       s              8
      D deleteHour      s              6
      D cmd             s           1024
      D PCfile          s           1024    varying
      D IFSFile         s           1024    varying
      D IFSobjFound     s               n
      D NotValidated    s             21    inz('*** NOT VALIDATED ***')
      D CHKEXTind       s               n
      D ALWEXTind       s               n
      D EXITPOINTSind   s               n
      C     eptkey        klist
      C                   kfld                    eptsubp
      C                   kfld                    eptsubpid
       *=========================================================================
       * Main processing path
       *=========================================================================
       /free
           //Set "DataLib" as current library
           // (this is needed by subprocedure ZHBGETINPUT in module XXXCGIPARS
           // in order to open file EXITPOINTS in library "DataLib"
           rc=docmd('chgcurlib ' + DataLib);
           // Check files
           exsr ChkF;
           //Load the external HTML
             IfsMultIndicators = getHtmlIfsMult(%trim(exthtml):'');
           //Open files
             exsr OpnF;
           //Set the validation global variables for the Javascript in the HTML
             exsr SetJsVars;
           //Check the active validations
             exsr ChkActVal;
           //Start the HTML response
             callp wrtsection('top');
             if ActVal1Ind=*on;
                callp wrtsection('valActive1');
             endif;
             if ActVal2Ind=*on;
                callp wrtsection('valActive2');
             endif;
             callp wrtsection('valActiveX');
           //Receive the main request
             nbrVars = zhbgetinput(savedquerystring:qusec);
             xrequest= zhbgetvarUpper('xrequest');
           //Examine the main request
             select;
             when xrequest=' ';
                  exsr Init;
             when xrequest='UPLOAD';
                  exsr Upload;
             when xrequest='DELETE';
                  exsr Delete;
             endsl;
           //Remove current library
             rc=docmd('chgcurlib *crtdft');
           //Flush buffer and quit
             callp wrtsection('*fini');
             return;
       /end-free
       *=========================================================================
       * The first time this program is called
       *=========================================================================
       /free
             begsr Init;
             callp updhtmlvar('errmsg':' ');
             callp wrtsection('fileend');
             endsr;
       /end-free
       *=========================================================================
       * The file upload was submitted
       * - the file upload was performed when subprocedure zhbGetInput() was run
       * - subprocedure zhbGetInput() makes the following input variables available:
       *     * browserfile             the name of the PC file
       *     * browserfile_tempfile    the name assigned to the IFS stream file
       *=========================================================================
       /free
            begsr Upload;
            PCfile  = zhbgetvar('browserfile');
            IFSfile = zhbgetvar('browserfile_tempfile');
            if %subst(IFSfile:1:21)=NotValidated;
               IFSfile=NotValidated;
            endif;
            callp updhtmlvar('errmsg':' ');
            callp updhtmlvar('pcfile':PCfile);
            callp updhtmlvar('ifsfile':IFSfile);
            callp wrtsection('filerow');
            if ifsfile<>NotValidated;
               callp wrtsection('filerowOK');
            else;
               callp wrtsection('filerowNOK');
            endif;
            callp wrtsection('fileend');
 
            // If the case, schedule a deletion of the uploaded file
            // 1- Check file existence
            IFSobjFound=chkIFSobj4(%trim(IFSfile));
            if IFSobjFound=*off;    // not found
               leavesr;
            endif;
            // 2- Check the name of the uploaded temporary file
            if %subst(uppify(IFSfile):1:5)<>'/TMP/';
               leavesr;
            endif;
            // 3- Check the name of the server
            serverName=getenv('SERVER_NAME':qusec);
            serverName=uppify(serverName);
            rc=%scan('.EASY400.NET':serverName);
            if rc=0;
               leavesr;
            endif;
            // 4- Schedule a delete job
            exsr SchedDelete;    //schedule a deletion of the uploaded file
 
            Endsr;
       /end-free
       *=========================================================================
       * Schedule a deletion of the uploaded file
       *=========================================================================
       /free
            Begsr SchedDelete;
 
            datfmt=rtvQDATFMT();   //retrieve system value QDATFMT (YMD, MDY, DMY, JUL)
            if datfmt='JUL';
               leavesr;    //give up
            endif;
 
            stampNow=%timestamp();
            deleteTime=stampNow + %minutes(15);
            deleteTimeC=%char(deleteTime);
            select;
            when datfmt='YMD';
                 deleteDay=%subst(deleteTimeC:1:4) +
                           %subst(deleteTimeC:6:2) +
                           %subst(deleteTimeC:9:2);
            when datfmt='MDY';
                 deleteDay=%subst(deleteTimeC:6:2) +
                           %subst(deleteTimeC:9:2) +
                           %subst(deleteTimeC:1:4);
            when datfmt='DMY';
                 deleteDay=%subst(deleteTimeC:9:1) +
                           %subst(deleteTimeC:6:2) +
                           %subst(deleteTimeC:1:4);
            endsl;
            deleteHour=%subst(deleteTimeC:12:2) +
                       %subst(deleteTimeC:15:2) +
                       %subst(deleteTimeC:18:2);
 
            cmd='del ''' + %trim(IFSfile) + '''';
            cmd='SBMJOB JOB(TMPPURGE) JOBQ(QSYSNOMAX) INQMSGRPY(*DFT) +
                SCDDATE('+deleteDay+') SCDTIME('+deleteHour+') +
                DATE(*SYSVAL) CMD('+%trim(cmd)+')';
            rc=doCmd(cmd);
 
            Endsr;
       /end-free
       *=========================================================================
       * Delete the stream file just uploaded
       * - the name of the IFS stream file to be deleted is received from
       *   the hidden field named "ifsfile"
       *=========================================================================
       /free
             begsr Delete;
             PCfile  = zhbgetvar('pcfile');
             IFSfile = zhbgetvar('ifsfile');
             if %subst(IFSFile:%len(IFSFile)-1:2)=x'0D25';     //if ending CRLF, ...
                IFSFile=%subst(IFSFile:1:%len(IFSFile)-2);     //drop CRLF
             endif;
             if IFSfile<>NotValidated;
                cmd='del '''+IFSfile+ '''';
                rc=docmd(cmd);
                if rc=0;
                   callp updhtmlvar('errmsg':' ');
                else;
                   callp updhtmlvar('errmsg':'IFS file ' +
                         %trim(IFSfile) + ' could not be deleted.');
                   callp updhtmlvar('pcfile':PCfile);
                   callp updhtmlvar('ifsfile':IFSfile);
                   callp wrtsection('filerow');
                endif;
             else;
                callp updhtmlvar('errmsg':' ');
             endif;
             callp wrtsection('fileend');
             endsr;
       /end-free
       *=====================================================================
       * Set the validation control variables for the Javascript in the HTML
       *=====================================================================
       /free
             Begsr SetJSVars;
 
             if CHKEXTind=*off or
                CHKEXTind=*off;
                YesNo='no';
                updhtmlvar('yesno':'no');
                updhtmlvar('alwextensions':' ');
                leavesr;
             endif;
 
             //Output variable 'AlwExtensions': used to set the allowed extensions
             nbrAlwExt=0;
             clear AlwExtensions;
             axtext=*loval;
             setll axtext axt;
             read axt;
             dow not %eof;
                 AlwExtensions=AlwExtensions+''''+%trim(axtext)+''',';
                 nbrAlwExt=nbrAlwExt+1;
                 read axt;
             enddo;
             if nbrAlwExt>0;
                AlwExtensions=%subst(AlwExtensions:1:%len(AlwExtensions)-1);//trim off the last comma
                AlwExtensions=%xlate(up:lw:AlwExtensions);
             endif;
 
             //Output variable 'YesNo': used to establish if the validation process should take place
             YesNo='no';
             if nbrAlwExt>0;
                rrn=1;
                chain rrn cxt;
                if %found and cxtYesNo='1';
                   YesNo='yes';
                endif;
             endif;
             updhtmlvar('yesno':YesNo);
             updhtmlvar2('alwextensions':%addr(AlwExtensions)+2:
                         %len(AlwExtensions));
 
             endsr;
       /end-free
       *=====================================================================
       * Check the active validations
       *=====================================================================
       /free
             Begsr ChkActVal;
 
             ActVal1Ind=*off;
             ActVal2Ind=*off;
 
             if CHKEXTind=*off or
                CHKEXTind=*off or
                EXITPOINTSind=*off;
                leavesr;
             endif;
 
             // Check client side validation
             if YesNo='yes';
                ActVal1Ind=*on;
             endif;
 
             // Check client side validation
            eptsubp='FILE-UPLOAD';
            eptsubpID='001';
            chain eptkey eptrcd;
            if %found and eptpgm<>' ' and eptpgmlib<>' ';
                rc=docmd('chkobj ' + %trim(eptpgmlib) + '/' +
                   %trim(eptpgm) + ' *pgm');
                if rc=0;
                   ActVal2Ind=*on;
                endif;
            endif;
 
             endsr;
       /end-free
       *=====================================================================
       * Check Files
       *=====================================================================
       /free
           Begsr ChkF;
 
           rc=doCmd('CHKOBJ ' + %trim(DataLib) + '/CHKEXT *FILE');
           if rc=0;
              CHKEXTind=*on;
           else;
              CHKEXTind=*off;
           endif;
 
           rc=doCmd('CHKOBJ ' + %trim(DataLib) + '/ALWEXT *FILE');
           if rc=0;
              ALWEXTind=*on;
           else;
              ALWEXTind=*off;
           endif;
 
           rc=doCmd('CHKOBJ *CURLIB/EXITPOINTS *FILE');
           if rc=0;
              EXITPOINTSind=*on;
           else;
              EXITPOINTSind=*off;
           endif;
 
           Endsr;
       /end-free
       *=====================================================================
       * Open Files
       *=====================================================================
       /free
           Begsr OpnF;
 
           if CHKEXTind=*on;
              if not %open(CHKEXT);
                 rc=docmd('ovrdbf CHKEXT ' + %trim(DataLib) + '/CHKEXT +
                    secure(*yes) ovrscope(*job)');
                 open CHKEXT;
              endif;
           endif;
 
           if ALWEXTind=*on;
              if not %open(ALWEXT);
                 rc=docmd('ovrdbf ALWEXT ' + %trim(DataLib) + '/ALWEXT +
                    secure(*yes) ovrscope(*job)');
                 open ALWEXT;
              endif;
           endif;
 
           if EXITPOINTSind=*on;
              if not %open(EXITPOINTS);
                 rc=docmd('ovrdbf EXITPOINTS ' + '*curlib/EXITPOINTS +
                    secure(*yes) ovrscope(*job)');
                 open EXITPOINTS;
              endif;
           endif;
 
           Endsr;
       /end-free
       *=====================================================================
       * Close Files
       *=====================================================================
       /free
           Begsr CloF;
 
           if CHKEXTind=*on;
              if %open(CHKEXT);
                 close CHKEXT;
                 rc=docmd('dltovr CHKEXT lvl(*job)');
              endif;
           endif;
 
           if ALWEXTind=*on;
              if %open(ALWEXT);
                 close ALWEXT;
                 rc=docmd('dltovr ALWEXT lvl(*job)');
           endif;
           endif;
 
           if EXITPOINTSind=*on;
              if %open(EXITPOINTS);
                 close EXITPOINTS;
                 rc=docmd('dltovr EXITPOINTS lvl(*job)');
              endif;
           endif;
 
           Endsr;
       /end-free
       *=========================================================================
       * Retrieve system value QDATFMT
      P rtvQDATFMT      b
      D rtvQDATFMT      pi             3
 
       * prototype for Retrieve System Values (QWCRSVAL) API
      D goQWCRSVAL      pr                  extpgm('QWCRSVAL')
      D                               31
      D                               10i 0
      D                               10i 0
      D                               10
      D  errCode                            like(qusec)
       * required parameter group for Retrieve System Values (QWCRSVAL) API
      D rcvVar          ds
      D  nbrRetVals                   10i 0
      D  offsetRetVal                 10i 0
      D  sysValInf                    23
      D rcvVarLen       s             10i 0  inz(%size(rcvVar))
      D nbrSysVals      s             10i 0  inz(1)
      D sysValName      s             10
       * Layout of System Value Information Table
      D sysvalInfTabP   s               *
      D sysvalInfTab    ds                  based(sysvalInfTabP)
      D  retSysValName                10
      D  retSysValDTyp                 1
      D  retSysValISts                 1
      D  retSysValLen                 10i 0
      D  retSysValVal                  3
       /free
            sysvalName='QDATFMT';
            goQWCRSVAL(rcvVar:rcvVarLen:nbrSysVals:sysValName:qusec);
            sysvalInfTabP=%addr(rcvVar)+offsetRetVal;
            return retSysValVal;
 
       /end-free
      P rtvQDATFMT      e
0.084 sec.s