*=====================================================================
* RPG ILE MODULE FUPLOAD/FUPLOAD
*
* CRTBNDRPG FUPLOAD/FUPLOAD DFTACTGRP(*NO) ACTGRP(*NEW) DBGVIEW(*SOURCE)
*
* Option switches:
* DETAILSW must be initialized to non-blank
* to provide detail analysis HTML report.
* Set this field to blank, not to issue
* the detail analysis HTML report.
*
*=====================================================================
/copy FUPLOAD/qrpglesrc,hspecs
/copy FUPLOAD/qrpglesrc,hspecsbnd
/copy FUPLOAD/qrpglesrc,prototypeb
/copy FUPLOAD/qrpglesrc,usec
*=================================
D extHtml s 2000 inz('/fupload/html/fupload.txt +
D /fupload/html/eot.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
*=================================
* OPTION SWITCHES
D DetailSW s 1a inz(' ')
*=================================
* VARIABLES TO CONTROL INPUT FILE
D InDta s 32767 based(InDtaP)
D InDtaLn s 10i 0
D RspLn s 10i 0
D StrOfDtaP s *
D CvtDta s 1000a
D CvtDtaLn s 10i 0
D OutDta s 1000a
D PartSepLn s 10i 0
D FileSize s 10i 0
D FileName s 512a
D ServerFile s 500a
D Description s 500a
D ServerDir s 500a
D FileType s 100a
D FileStrPos s 10i 0
*=================================
* VARIABLES FOR IFS "STAT" FUNCTION
* Buffer for IFS stat function
D StatusBuffer ds align
D StsPermissions...
D 10u 0
D StsFileID 10u 0
D StsLinkCount 5u 0
D StsUserIDNbr 10u 0
D StsGroupIdNbr 10u 0
D StsBytesInFile...
D 10i 0
D StsTimeLastAcc...
D 10i 0
D StsTimeLastChg...
D 10i 0
D StsTimeStsLastChg...
D 10i 0
D StsFileSysID 10u 0
D StsBlockSize 10u 0
D StsAllocBytes 10u 0
D StsObjectType 11
D StsCodePage 5u 0
D 62
D StsGenerationID...
D 10u 0
D CodePage s 10u 0 inz(819)
D FileHandle s 10i 0
D ErrNoRet s 10i 0
*=================================
* VARIABLES TO CHECK AN IFS FILE
D IfsFnd s n
D IfsObjType s 11 varying
D IfsObjSize s 10i 0
D rc s 10i 0 inz(0)
D ThisSubProc c 'FUPLOAD: '
*=================================
* VARIABLES TO PROVIDE USER RESPONSE
D DoneSW s 1a
D TextSW s 1a
D OutData s 100a
*=================================
* VARIABLES TO HANDLE MESSAGES
D ErrorType s 10i 0
D msg1 s 1600a
D msg2 s 1600a
D msg3 s 1600a
D msg4 s 1600a
D msg5 s 1600a
D DS
D msg 1 1600
D msgid 1 7
D msgsev 8 9
D msgtxt1 10 521
D msgtxt2 522 1600
*=================================
* MISCELLANEOUS VARIABLES
D DataLib c 'FUPLOADDT'
D EOR s 2a inz(x'0D25')
D key1 s 58a
D key2 s 13a inz('Content-Type:')
D key3 s 21a
D key4 s 22a
D UserName s 512a
D Cmd s 1024a
D DlyNbr s 10i 0
D i s 10i 0
D j s 10i 0
D k s 10i 0
D l s 10i 0
D m s 10i 0
D r s 10i 0
D s s 10i 0
D t s 10i 0
D x s 10i 0
D y s 10i 0
*=================================
* VARIABLES FOR PROGRAM STATUS SUBROUTINE
D psds sds
D psdsdata 429
D pssrswitch s 1 inz(*off)
D wrotetop s 1 inz(*off)
*===========================================
* PART 0- PROLOG
*===========================================
/free
// in order to open file EXITPOINTS in library "DataLib"
rc=docmd('chgcurlib ' + DataLib);
/end-free
* Initialize search keys
C eval key1 = 'Content-Disposition: form-data;' +
C ' name="filesnt"; filename="'
C eval key3 = 'name="serverfile"' + EOR + EOR
C eval key4 = 'name="description"' + EOR + EOR
* Get externally described HTML, start response
C eval IfsMultIndicators = getHtmlIfsMult(
C %trim(exthtml):'<as400>')
C callp wrtsection('top')
C eval wrotetop = *on
* Retrieve logged-in user name (if protection active)
C eval UserName = getenv('REMOTE_USER':qusec)
*====================================================================
* PART 1 - ASK USER INPUT
*====================================================================
* Get content length
C eval InDtaLn = contlen
C if InDtaLn = 0
C callp wrtsection('step1')
C exsr Exit
C endif
*====================================================================
* PART 2- ALLOCATE STORAGE TO RECEIVE INPUT
* RECEIVE INPUT
*====================================================================
* Allocate storage for content-length bytes. Storage addressed by pointer "IndtaP".
C alloc(e) InDtaLn InDtaP
C if InDtaP = *null
C exsr AllocErr
C endif
* Read standard input using API instead of any of CGIDEV2's
* getinput because length can easily be larger than getinput's
* maximum buffer size of 32767.
C callb 'QtmhRdStin'
C parm InDta
C parm InDtaLn
C parm RspLn
C parm qusec
*====================================================================
* PART 3 - DETAIL ANALYSIS OF INPUT DATA
* (display it only if "DetailSW"<>' ')
*====================================================================
* Convert initial input data to EBCDIC
* - establish the length of the data to be copied
C eval CvtDtaLn = %len(CvtDta)
C if InDtaLn < CvtDtaLn
C eval CvtDtaLn = InDtaLn
C endif
C if CvtDtaLn > 1000
C eval CvtDtaLn = 1000
C endif
* - copy "InDta" to "CvtDta"
C eval CvtDta=%subst(InDta:1:CvtDtaLn)
* - convert "CvtDta" contents from ASCII to EBCDIC
C eval CvtDta = xlatwCCSIDS(*on:CvtDta)
* Display initial input data converted to EBCDIC
C IF DetailSW <> ' '
C callp updhtmlvar('length':
C %editc(InDtaLn :'J'))
C callp wrtsection('step2')
C eval OutDta = CvtDta
C x'0d':'|' xlate OutDta OutDta
C x'25':'|' xlate OutDta OutDta
C ' ':'.' xlate OutDta OutDta
C eval x = 1
C eval y = 0
*
C dow y < CvtDtaLn
C eval r = CvtDtaLn - y
C if r > 100
C eval l = 100
C else
C eval l = r
C endif
C eval OutData = %subst(OutDta:x:l)
C callp updhtmlvar('outdata':outdata)
C callp wrtsection('datarow')
C eval y = y + l
C eval x = x + l
C enddo
*
C callp wrtsection('datarowe')
C ENDIF
* Display MIME headers:
C IF DetailSW <> ' '
C eval x = 1
C eval r = 1
C dow r > 0
C eval r = %scan('Content-':CvtDta:x)
C eval t = %scan(EOR:CvtDta:x)
C if r > 0
C eval s = %scan(':':CvtDta:r)
C if s > 0 and t>s
C callp updhtmlvar('header':
C %subst(CvtDta:r:s-r))
C callp updhtmlvar('params':
C %subst(CvtDta:s+2:t-(s+2)+1))
C callp wrtsection('headerrow')
C endif
C endif
C eval x = t +2
C enddo
C callp wrtsection('headerrowe')
C ENDIF
* Retrieve control data:
* 1-path and name of the local file to be uploaded
C eval r = %scan(key1:CvtDta)
C if r>0
C eval s = %scan(EOR:CvtDta:r)
C eval FileName = %subst(CvtDta:
C r + %len(key1):
C s - (r + %len(key1))-1)
C endif
* 2-type of the local file to be uploaded
C eval r = %scan(key2:CvtDta)
C if r>0
C eval s = %scan(EOR:CvtDta:r)
C eval FileType = %subst(CvtDta:
C r + %len(key2):
C s - (r + %len(key2)))
C endif
* 3-start position (in the buffer) of the file to be uploaded
C eval FileStrPos = s +4
* 4a-length of part separator "------------------..."
C eval PartSepLn = %scan(EOR:CvtDta)
* 4b-size of the file to be uploaded
C eval FileSize = InDtaLn - FileStrPos -
C PartSepLn -4
* 5-path and name of the server IFS file to be created
C eval r = %scan(key3:CvtDta)
C if r > 0
C eval s = %scan(EOR:CvtDta:r+%len(key3))
C if s > 0
C eval ServerFile = %subst(CvtDta:r+%len(key3):
C s - (r+%len(key3)))
C endif
C endif
* 6-description (this parameter is just for demonstration)
C eval r = %scan(key4:CvtDta)
C if r > 0
C eval s = %scan(EOR:CvtDta:r+%len(key4))
C if s > 0
C eval Description = %subst(CvtDta:r+%len(key4):
C s - (r+%len(key4)))
C endif
C endif
*
C IF DetailSW <> ' '
C callp updhtmlvar('filename':FileName)
C callp updhtmlvar('filetype':FileType)
C callp updhtmlvar('filestrpos':
C %editc(FileStrPos:'J'))
C callp updhtmlvar('partsepln':
C %editc(PartSepLn:'J'))
C callp updhtmlvar('filesize':
C %editc(FileSize:'J'))
C callp updhtmlvar('serverfile':ServerFile)
C callp updhtmlvar('description':Description)
C callp wrtsection('ctldata')
C ENDIF
*=====================================================================
* PART 4 - CHECK THE TARGET DIRECTORY
*=====================================================================
* Retrieve the directory
C eval ServerDir = '/'
C eval r = %scan('/':ServerFile)
C dow r > 0
C eval r = %scan('/':ServerFile:r+1)
C if r > 0
C eval s = r
C endif
C enddo
* Check the directory
C IF s > 1
C eval ServerDir = %subst(ServerFile:1:s-1)
C callp updhtmlvar('serverdir':ServerDir)
C eval IfsFnd=chkIfsObj2(%trim(ServerDir):
C IfsObjType:IfsObjSize)
C if IfsFnd<>*on
C callp wrtsection('baddir')
C exsr Exit
C endif
C ENDIF
*=====================================================================
* PART 5 - COPY INPUT FILE TO SREAM FILE
*=====================================================================
C exsr WrtDta
*=====================================================================
* PART 6 - PROVIDE USER RESPONSE
*=====================================================================
* Write out the input file information
C callp UpdHTMLVar('filename':FileName)
C callp UpdHTMLVar('filetype':FileType)
C callp UpdHTMLVar('filesize':
C %trim(%editc(FileSize:'J')))
C callp wrtsection('strresult')
* Display result of operation
C callp updhtmlvar('serverfile':ServerFile)
C if doneSW = 'Y'
C callp wrtsection('done')
C else
C callp wrtsection('notdone')
C exsr DspErrMsg
C endif
C callp updhtmlvar('description':Description)
C callp wrtsection('donee')
* Deallocate input buffer pointed by "IndtaP".
C dealloc(e) InDtaP
*
C exsr Exit
*=====================================================================
* Back to caller
*=====================================================================
C Exit begsr
* Close html and send buffer
C callp wrtsection('endhtml *fini')
* Back to caller
C eval *inlr = *on
C return
C endsr
*=====================================================================
* Create and write the IFS output file
*=====================================================================
C WrtDta begsr
* Assume it fails
C eval DoneSW = 'N'
C eval ErrorType = 0
* Unlink (delete) the file if it already exists.
C eval dlynbr = 0
C dow stat(%trim(ServerFile):
C %addr(StatusBuffer)) = 0
C eval rc = unlink(%trim(ServerFile))
C if rc <> 0
C eval dlynbr = dlynbr +1
C if dlynbr > 5
C leave
C endif
C eval rc = docmd('dlyjob 10')
C endif
C enddo
* Open stream file
C eval FileHandle = open(%trim(ServerFile):
C O_CREAT + O_WRONLY +
C O_TRUNC + O_TEXTDATA + O_CODEPAGE:
C S_IRWXU + S_IROTH + S_IXOTH:CodePage)
C if FileHandle = -1
C eval ErrNoRet = errno
C eval msg1 = ThisSubProc + 'Open of IFS file ' +
C %trim(ServerFile) +
C ' failed. Message text is ' +
C errnotxt(ErrNoRet)
C callp wrtdebug(msg1:*on)
C eval ErrorType = 1
C goto WrtDtaX
C endif
* Write buffer to the streamfile
C eval StrOfDtaP = InDtaP + FileStrPos -1
C eval rc = write(FileHandle:
C StrOfDtaP:FileSize)
C if rc = -1
C eval ErrNoRet = errno
C eval msg1 = ThisSubProc + 'Write into IFS -
C file ' + %trim(ServerFile) +
C ' failed. Message text is ' +
C errnotxt(ErrNoRet)
C callp wrtdebug(msg1:*on)
C eval ErrorType = 3
C goto WrtDtaX
C endif
* Close streamfile
C eval rc = close(FileHandle)
C if rc = -1
C eval ErrNoRet = errno
C eval msg1 = ThisSubProc + 'Close of IFS file '+
C %trim(ServerFile) +
C ' failed. Message text is ' +
C errnotxt(ErrNoRet)
C callp wrtdebug(msg1:*on)
C eval ErrorType = 2
C goto WrtDtaX
C endif
* File was correctly created and written
C eval DoneSW = 'Y'
*
C WrtDtaX tag
C endsr
*====================================================================
* Memory allocation error
*====================================================================
C AllocErr begsr
C callp updhtmlvar('indtaln':
C %editc(InDtaLn:'J'))
C callp wrtsection('allocerr')
C exsr Exit
C endsr
*====================================================================
* Display error messages
*====================================================================
C DspErrMsg begsr
C eval msg = msg1
C exsr MsgRow
C eval msg = msg2
C exsr MsgRow
C eval msg = msg3
C exsr MsgRow
C eval msg = msg4
C exsr MsgRow
C eval msg = msg5
C exsr MsgRow
C endsr
*=====================================================================
* Issue a message row
*=====================================================================
C MsgRow begsr
C IF msgid <> ' '
C callp updhtmlvar('msgid':msgid)
C callp updhtmlvar('msgsev': msgsev)
C callp updhtmlvar('msgtxt1':msgtxt1)
C eval l = %size(msgtxt2)
*
C eval r = %scan('&N':msgtxt2)
C dow r > 0
C if r = 1
C eval msgtxt2 = %subst(msgtxt2:3:l-2)
C else
C eval msgtxt2 = %subst(msgtxt2:1:r-1) +
C '<br>' + %subst(msgtxt2:r+2:l-r-1)
C endif
C eval r = %scan('&N':msgtxt2)
C enddo
*
C eval r = %scan('&P':msgtxt2)
C dow r > 0
C if r = 1
C eval msgtxt2 = %subst(msgtxt2:3:l-2)
C else
C eval msgtxt2 = %subst(msgtxt2:1:r-1) +
C '<br>' + %subst(msgtxt2:r+2:l-r-1)
C endif
C eval r = %scan('&P':msgtxt2)
C enddo
*
C eval r = %scan('&B':msgtxt2)
C dow r > 0
C if r = 1
C eval msgtxt2 = %subst(msgtxt2:3:l-2)
C else
C eval msgtxt2 = %subst(msgtxt2:1:r-1) +
C '<li>' + %subst(msgtxt2:r+2:l-r-1)
C endif
C eval r = %scan('&B':msgtxt2)
C enddo
*
C callp updhtmlvar('msgtxt2':msgtxt2)
C callp wrtsection('msgrow1')
C if msgtxt2 <> ' '
C callp wrtsection('msgrow2')
C endif
C ENDIF
C endsr
*=====================================================================
* PROGRAM STATUS SUBROUTINE
*=====================================================================
C *pssr begsr
C if pssrswitch=*on
C eval *inlr = *on
C return
C endif
C eval pssrswitch=*on
C if wrotetop=*off
C callp wrtsection('top')
C endif
C callp wrtsection('pssr *fini')
C callp wrtpsds(psds)
C eval *inlr = *on
C return
C endsr
|