*********************************************************************
*
* Please note the following:
*
* 1) The SENDER PARM in the SNDEMAIL command has the email address
* of the Harter system administrator hard-coded in. You will
* want to change this to your default system e-mail address.
*
* 2) The SNDEMAILC is a CLLE program. Please compile per the
* instructions listed in it's documentation.
*
* 3) The SNDEMAILR is an RPGLE program. Please compile per the
* instructions listed in it's documentation.
*
* 4) The SNDEMAIL command has compile instructions in the source code.
*
* 5) The SNDEMAILC creates a data area in the QGPL library. You may
* change this to where ever you want it to reside. Simply change
* the value on the declare of the &DTAARALIB variable.
*
* 6) The MIME header files are automatically created in the /TMP
* directory in the IFS. If you wish them to be created somewhere
* else, simply change the line in SNDEMAILC which builds the MIME
* file name.
*
* 7) The SNDEMAILR program retrieves the QUTCOFFSET (Coordinated
* universal time offset) System Value. This value is used in
* creating the date and time information on the MIME header file.
* If yours is not set properly (as ours was not before I created
* this program) you will need to do so.
*
* 8) There is an undocumented feature that is available for the
* Message parameter. You can use any of the following special
* codes in the text of the message: or - New Line,
* - Tab.
*
*********************************************************************
H*****************************************************************
H* DIRECTIVES- *
H* PARM TEXT('SEND A MIME E-MAIL.')
H*****************************************************************
H* To create this program, issue the following:
H* CRTRPGMOD lib/SNDEMAILR SRCFILE(srclib/srcfile)
H* CRTPGM lib/SNDEMAILR MODULE(lib/SNDEMAILR) BNDSRVPGM(QTCP/QTMMSNDM)
H*****************************************************************
H* PROGRAMMER -D. LELAND
H* DATE WRITTEN-03/17/1998
H*****************************************************************
H* NARRATIVE-
H* THIS PROGRAM WILL SEND A MIME E-MAIL.
H*****************************************************************
FEMAILLOG O E DISK
* Pointers
D TNulPtr S *
D TPointer S * Based(TNulPtr)
D TBuffPtr S * Based(TNulPtr)
D TProcPtr S * Based(TNulPtr) ProcPtr
* Character & String
D TChar S 1 Based(TNulPtr)
D TWChar S 2 Based(TNulPtr)
D TString S 256 Based(TNulPtr)
* Integers - signed
D TShort S 5I 0 Based(TNulPtr)
D TInt S 10I 0 Based(TNulPtr)
D TLong S 10I 0 Based(TNulPtr)
* C type integers - unsigned
D TShort_u S 5U 0 Based(TNulPtr)
D TInt_u S 10U 0 Based(TNulPtr)
D TLong_u S 10U 0 Based(TNulPtr)
* Names/400
D TName S 10 Based(TNulPtr)
D TLongName S 20 Based(TNulPtr)
* //Bitwise routines
DcNOT PR Like(TChar)
D factor1 Like(TChar) Value
DcAND PR Like(TChar)
D factor1 Like(TChar) Value
D factor2 Like(TChar) Value
DcOR PR Like(TChar)
D factor1 Like(TChar) Value
D factor2 Like(TChar) Value
DcLShift PR Like(TChar)
D factor1 Like(TChar) Value
D shiftcount Like(TInt_u) Value
DcRShift PR Like(TChar)
D factor1 Like(TChar) Value
D shiftcount Like(TInt_u) Value
DuAND PR Like(TInt_u)
D factor1 Like(TInt_u) Value
D factor2 Like(TInt_u) Value
DcOrd PR Like(TInt_u)
D factor1 Like(TChar) Value
*//The BASE64 encoding
DsEncodeLineB64 PR Like(TString)
D LineIn Like(TString) Value
D SizeIn Like(TInt_u)
*//Get the name of the attached file, by index
DAttachFile PR Like(TString)
D Index Like(TInt) Value
*//Get the encoding requested for the attached file,
*//by index
DAttachEncode PR Like(TChar)
D Index Like(TInt) Value
F*****************************************************************
D* IFS PROTOTYPES
* **************************************************************
* open an IFS file
Dopen PR 10I 0 EXTPROC('open')
D filename * VALUE
D openflags 10I 0 VALUE
D mode 10U 0 VALUE OPTIONS(*NOPASS)
D codepage 10U 0 VALUE OPTIONS(*NOPASS)
* read an IFS file
Dread PR 10I 0 EXTPROC('read')
D filehandle 10I 0 VALUE
D datareceived * VALUE
D nbytes 10U 0 VALUE
* write to an IFS file
Dwrite PR 10I 0 EXTPROC('write')
D filehandle 10I 0 VALUE
D datatowrite * VALUE
D nbytes 10U 0 VALUE
* close an IFS file
Dclose PR 10I 0 EXTPROC('close')
D filehandle 10I 0 VALUE
* retrieve information about an IFS file
Dstat PR 10I 0 EXTPROC('stat')
D filename * VALUE
D bufpointer * VALUE
* **************************************************************
D* IFS CONSTANTS
* **************************************************************
* cmd Values for fcntl()
* Duplicate a file des
D F_DUPFD S 10I 0 INZ(0)
* Get locking informat
D F_GETLK S 10I 0 INZ(3)
* Set locking informat
D F_SETLK S 10I 0 INZ(4)
* Set locking informat
D F_SETLKW S 10I 0 INZ(5)
* Get file status flag
D F_GETFL S 10I 0 INZ(6)
* Set file status flag
D F_SETFL S 10I 0 INZ(7)
* File Access Modes for open()
* Open for reading only
D O_RDONLY S 10I 0 INZ(1)
* Open for writing only
D O_WRONLY S 10I 0 INZ(2)
* Open for reading and writing
D O_RDWR S 10I 0 INZ(4)
* oflag Values for open()
* Create file if it do
D O_CREAT S 10I 0 INZ(8)
* Exclusive use flag
D O_EXCL S 10I 0 INZ(16)
* Truncate flag
D O_TRUNC S 10I 0 INZ(64)
* File Status Flags for open() and fcntl()
* No delay...return EA
D O_NONBLOCK S 10I 0 INZ(128)
* Set append mode
D O_APPEND S 10I 0 INZ(256)
* oflag Share Mode Values for open()
* Share with neither r
D O_SHARE_NONE S 10I 0 INZ(2000000)
* Share with readers o
D O_SHARE_RDONLY S 10I 0 INZ(0200000)
* Share with readers a
D O_SHARE_RDWR S 10I 0 INZ(1000000)
* Share with writers o
D O_SHARE_WRONLY S 10I 0 INZ(0400000)
* file permissions
* Owner - read
D S_IRUSR S 10I 0 INZ(256)
* Owner - write
D S_IWUSR S 10I 0 INZ(128)
* Owner - execute
D S_IXUSR S 10I 0 INZ(64)
* Owner - all
D S_IRWXU S 10I 0 INZ(448)
* Group - read
D S_IRGRP S 10I 0 INZ(32)
* Group - write
D S_IWGRP S 10I 0 INZ(16)
* Group - excecute
D S_IXGRP S 10I 0 INZ(8)
* Group - all
D S_IRWXG S 10I 0 INZ(56)
* Others - read
D S_IROTH S 10I 0 INZ(4)
* Others - write
D S_IWOTH S 10I 0 INZ(2)
* Others - execute
D S_IXOTH S 10I 0 INZ(1)
* Others - all
D S_IRWXO S 10I 0 INZ(7)
* misc
* Owner - read
D O_TEXTDATA S 10I 0 INZ(16777216)
* Owner - read
D O_CODEPAGE S 10I 0 INZ(8388608)
* **************************************************************
D* DATA DEFINITIONS
* **************************************************************
*// The BASE64 ordinal set; 'A'=0, 'B'=1, 'C'=2...'+'=62, '/'=63
D Bin2Base64 C 'ABCDEFGHIJKLMNOPQRSTUVWXYZ-
D abcdefghijklmnopqrstuvwxyz-
D 0123456789+/'
*// Note: The E_Line_Length and %LEN(DataRead) are related
*// in this implementation.
*// Read the comment at the definition of DataRead for
*// more information.
D E_Line_Length C 45
D E_Offset S Like(TInt_u)
D E_Length S Like(TInt_u)
D E_Line S Like(TString)
D FileName S 255A
D FileLen S 9B 0
D Originator S 255A
D OriginName S 256A
D OriginLen S 9B 0
D CPFNumber S Like(CPFID)
D Subject S 256A
D Message S 512A
D WrkMsg S 1024A
D AttachName S 256A
D AsciiCodePage S 10U 0 INZ(819)
D CodePage S 10U 0 INZ(37)
*
D Addressee S Like(Address)
D AddresseeName S Like(Address)
D RecipType S 1S 0
*
D AddresseeDS DS
D NbrRecip 1 2B 0
D AddressFull 3 7727A Dim(15)
*
D Recipient DS
D OffSet 1 4B 0 Inz
D AddrLen 5 8B 0 Inz
D Format 9 16 Inz('ADDR0100')
D DistrType 17 20B 0 Inz
D RReserved 21 24B 0 Inz
D Address 25 280 Inz
*
D Recipients S 4200A
*
D Receiver DS 128
D OpSysVer 20 25
*
D TotalRecp S 9B 0
D FileDesc S 10I 0
D BytesWrt S 10I 0
D Data S 9999A
D AttachDesc S 10I 0
D BytesRead S 10I 0
*//Change DataRead so that %Size(DataRead)/E_Line_Length
*//is a whole number.
*//This simplifies implementation of Base64 encoding as
*//any block read can be completely encoded by multiple
*//calls to sEncodeBase64
D DataRead S 9000A
D CRLF S 2A Inz(X'0D25')
D Null S 1A Inz(X'00')
D FullName S 512A
D ReturnInt S 10I 0
D Pos S 5U 0
D SavePos S Like(Pos)
D FullAttachName S 512A
* LT RRN ARRAY
D LengthB S 9B 0 INZ(%SIZE(RtnVal))
* LT RRN ARRAY
D NumRtvB S 9B 0 INZ(1)
D RtnVal DS 37
D QUTCOFFSET 29 33
D X S 5 0
D Y S 5 0
* Date stuff
* LT RRN ARRAY
D DateOut S 32A
* LT RRN ARRAY
D DateFmt S 32A
* LT RRN ARRAY
D LilianDate S 9B 0 INZ
D FC1 DS INZ
D Sev1 4B 0
D MsgNo1 4B 0
D Flags1 1
D Facid1 3
D ISI1 9B 0
* MIME Header fields
D MSender S 256A
D MDateTime S 256A
D MFrom S 256A
D MMimeVer S 256A
D MTo S 9999A Inz
D MCC S 9999A Inz
D MBCC S 9999A Inz
D MSubject S 256A
D MBoundary S 256A Inz('--PART.BOUNDARY.1')
D* Change Attachment DS to accept Encoding Type
D AttachRec DS
D fAttachNbr 2B 0
D fAttachFile 256A
D fAttachEncode 1A
*
D Attachment DS
D NbrFiles 2B 0
D AttachInfo Like(AttachRec) Dim(30)
*
D APIError DS
D APIBytes 1 4B 0
D CPFID 9 15
*
D MsgSize C Const(%Len(Message))
* stat data sructure
D StatDS DS 128
D st_mode 10U 0
D st_ino 10U 0
D st_nlink 5U 0
D reserved1 2A
D st_uid 10U 0
D st_gid 10U 0
D st_size 10U 0
D st_atime 10U 0
D st_mtime 10U 0
D st_ctime 10U 0
D st_dev 10U 0
D st_blksize 10I 0
D st_allocsize 10I 0
D st_objtype 10A
D reserved2 2A
D st_codepage 5U 0
D st_reserved1 62A
D st_ino_gen_id 10U 0
D* **************************************************************
D* PROGRAM STATUS DATA STRUCTURE
D* **************************************************************
D PGMDS SDS 429
D PGMNM 1 10
D JOBNM 244 253
D USRNM 358 367
D JOBNBR 264 269 0
D #PARMS *PARMS
C*****************************************************************
C* MAIN LINE CALCULATIONS
C*****************************************************************
C* Entry Parms
C *ENTRY PLIST
C PARM FileName
C Parm Attachment
C Parm AddresseeDS
C Parm Subject
C Parm Message
C Parm Originator
C Parm OriginName
C Parm CPFId CPFNumber
C* Initialize error structure
C Eval APIBytes = 11
C* Initialize values
C Eval FileLen = %Len(%Trimr(FileName))
C Eval %Subst(FileName:FileLen+1:2) = X'0000'
C Eval OriginLen = %Len(%Trimr(Originator))
C Eval TotalRecp = NbrRecip
C Clear MTo
C Clear MCC
C Clear MBCC
C* Build data structure of recipients
C Clear Recipients
C Do NbrRecip X
C Eval Addressee = %Subst(AddressFull(X):3:256)
C Eval AddresseeName =
C %Subst(AddressFull(X):259:256)
C Move AddressFull(X)RecipType
C Eval Format = 'ADDR0100'
C Eval DistrType = RecipType
C Eval RReserved = 0
C Eval Address = Addressee
C Eval AddrLen = %Len(%Trimr(Address))
C If X >= NbrRecip
C Eval OffSet = 0
C Else
C Eval OffSet = %Len(%Trimr(Recipient))
C Endif
C Eval Recipients = %Trimr(Recipients) +
C %Trimr(Recipient)
C Enddo
C* Retrieve current date and time
C Eval LTime = Utime
C Move *DATE LDate
C* Write MIME file
C Exsr WriteHdr
C* Call API to send e-mail
C CallB 'QtmmSendMail'
C Parm FileName
C Parm FileLen
C Parm Originator
C Parm OriginLen
C Parm Recipients
C Parm TotalRecp
C Parm APIError
C* Write e-mail log
C If %Len(%Trimr(MTo) +
C %Trimr(MCC) +
C %Trimr(MBCC)) <= 256
C Eval LTo = %Trimr(MTo) + %Trimr(MCC) +
C %Trimr(MBCC)
C Else
C Movel MTo LTo
C ' ':'*' Xlate LTo LTo
C Endif
C Movel Subject LSubject
C Eval LMsgID = CPFID
C If NbrFiles > *Zero
C and AttachFile(1) <> '*NONE'
C Do NbrFiles Z
C If Z = 1
C Eval LAttach = AttachFile(Z)
C Else
C Eval LAttach = %Trimr(LAttach) + ' ' +
C %Trimr(AttachFile(Z))
C Endif
C Enddo
C Else
C Clear LAttach
C Endif
C Write Emaillogr
C* Return to caller
C Exit Tag
C Return
C*****************************************************************
C* Write header portion of file
C*****************************************************************
CSR WriteHdr Begsr
C* Open file
C Eval FullName = %TRIMR(FileName) + Null
C Eval FileDesc = open(%ADDR(FullName)
C : O_CREAT + O_WRONLY + O_TRUNC +
C O_CODEPAGE
C : S_IRWXU + S_IRWXO
C : AsciiCodePage)
C Eval ReturnInt = close(FileDesc)
C Eval FileDesc = open(%ADDR(FullName)
C : O_TEXTDATA + O_RDWR)
C* Convert to newline or tab
C Eval Y = 1
C Do MsgSize X
C If X + 4 <= MsgSize and
C (%Subst(Message:X:5) = ''
C Or %Subst(Message:X:5) = '')
C Eval %Subst(WrkMsg:Y:2) = CRLF
C Eval Y = Y + 2
C Eval X = X + 4
C Else
C If X + 3 <= MsgSize and
C (%Subst(Message:X:4) = ''
C Or %Subst(Message:X:4) = '')
C Eval %Subst(WrkMsg:Y:2) = CRLF
C Eval Y = Y + 2
C Eval X = X + 3
C Else
C If X + 4 <= MsgSize and
C (%Subst(Message:X:5) = ''
C Or %Subst(Message:X:5) = '')
C Eval %Subst(WrkMsg:Y:1) = X'05'
C Eval Y = Y + 1
C Eval X = X + 4
C Else
C Eval %Subst(WrkMsg:Y:1) = %Subst(Message:X:1)
C Eval Y = Y + 1
C Endif
C Endif
C Endif
C Enddo
C* Current time
C Time Utime 6 0
C* Sender
C Eval MSender =
C 'Sender: ' + Originator
C* Date & Time
C Exsr RtvFmtDate
C Eval MDateTime =
C 'Date: ' +
C %Trimr(DateOut) + ' ' +
C %Trimr(%EditW(Utime:' : : ')) +
C ' ' + QUTCOFFSET
C* From
C If OriginName <> *Blanks
C Eval MFrom =
C 'From: ' +
C %Trimr(OriginName) + ' <' +
C %Trimr(Originator) + '>'
C Else
C Eval MFrom =
C 'From: ' + Originator
C Endif
C* MIME Version
C Eval MMimeVer =
C 'MIME-Version: 1.0'
C* Retrieve data structure of recipients - "To:"
C Eval Y = *Zero
C Do NbrRecip X
C Move AddressFull(X)RecipType
C If RecipType = 0
C Eval Y = Y + 1
C If Y > 1
C Eval MTo = %Trimr(MTo) + ';'
C Endif
C If %Subst(AddressFull(X):259:256) > *Blanks
C If Y = 1
C Eval MTo = 'To: ' +
C %Trimr(%Subst(AddressFull(X):259:256)) +
C ' <' +
C %Trimr(%Subst(AddressFull(X):3:256)) +
C '>'
C Else
C Eval MTo = %Trimr(MTo) +
C %Trimr(%Subst(AddressFull(X):259:256)) +
C ' <' +
C %Trimr(%Subst(AddressFull(X):3:256)) +
C '>'
C Endif
C Else
C If X = 1
C Eval MTo = 'To: ' +
C %Trimr(MTo) +
C %Trimr(%Subst(AddressFull(X):3:256))
C Else
C Eval MTo = %Trimr(MTo) +
C %Trimr(%Subst(AddressFull(X):3:256))
C Endif
C Endif
C Endif
C Enddo
C* Retrieve data structure of recipients - "Cc:"
C Eval Y = *Zero
C Do NbrRecip X
C Move AddressFull(X)RecipType
C If RecipType = 1
C Eval Y = Y + 1
C If Y > 1
C Eval MCC = %Trimr(MCC) + ';'
C Endif
C If %Subst(AddressFull(X):259:256) > *Blanks
C If Y = 1
C Eval MCC = 'Cc: ' +
C %Trimr(%Subst(AddressFull(X):259:256)) +
C ' <' +
C %Trimr(%Subst(AddressFull(X):3:256)) +
C '>'
C Else
C Eval MCC = %Trimr(MCC) +
C %Trimr(%Subst(AddressFull(X):259:256)) +
C ' <' +
C %Trimr(%Subst(AddressFull(X):3:256)) +
C '>'
C Endif
C Else
C If X = 1
C Eval MCC = 'Cc: ' +
C %Trimr(MCC) +
C %Trimr(%Subst(AddressFull(X):3:256))
C Else
C Eval MCC = %Trimr(MCC) +
C %Trimr(%Subst(AddressFull(X):3:256))
C Endif
C Endif
C Endif
C Enddo
C* Retrieve data structure of recipients - "BCc:"
C Eval Y = *Zero
C Do NbrRecip X
C Move AddressFull(X)RecipType
C If RecipType = 2
C Eval Y = Y + 1
C If Y > 1
C Eval MBCC = %Trimr(MBCC) + ';'
C Endif
C If %Subst(AddressFull(X):259:256) > *Blanks
C If Y = 1
C Eval MBCC = 'BCc: ' +
C %Trimr(%Subst(AddressFull(X):259:256)) +
C ' <' +
C %Trimr(%Subst(AddressFull(X):3:256)) +
C '>'
C Else
C Eval MBCC = %Trimr(MBCC) +
C %Trimr(%Subst(AddressFull(X):259:256)) +
C ' <' +
C %Trimr(%Subst(AddressFull(X):3:256)) +
C '>'
C Endif
C Else
C If X = 1
C Eval MBCC = 'BCc: ' +
C %Trimr(MBCC) +
C %Trimr(%Subst(AddressFull(X):3:256))
C Else
C Eval MBCC = %Trimr(MBCC) +
C %Trimr(%Subst(AddressFull(X):3:256))
C Endif
C Endif
C Endif
C Enddo
C* Subject
C If Subject > *Blanks
C Eval MSubject =
C 'Subject: ' + Subject
C Else
C Eval MSubject =
C 'Subject: '
C Endif
C* Build data string of MIME header
C Eval Data = %Trimr(MSender) +
C CRLF +
C %Trimr(MDateTime) +
C CRLF +
C %Trimr(MFrom) +
C CRLF +
C %Trimr(MMimeVer) +
C CRLF
C If MTo <> *Blanks
C Eval Data = %Trimr(Data) +
C %Trimr(MTo) +
C CRLF
C Endif
C If MCC <> *Blanks
C Eval Data = %Trimr(Data) +
C %Trimr(MCC) +
C CRLF
C Endif
C If MBCC <> *Blanks
C Eval Data = %Trimr(Data) +
C %Trimr(MBCC) +
C CRLF
C Endif
C Eval Data = %Trimr(Data) +
C %Trimr(MSubject) +
C CRLF +
C 'Content-Type: multipart/mixed; boundary=' +
C '"' + %Trimr(MBoundary) + '"' +
C CRLF +
C CRLF +
C 'This is a multi-part message in MIME ' +
C 'format.' + CRLF + CRLF +
C '--' + %Trimr(MBoundary) +
C CRLF +
C 'Content-Type: text/plain; charset=us-ascii'+
C CRLF +
C 'Content-Transfer-Encoding: 7bit' +
C CRLF + CRLF +
C %Trimr(WrkMsg) +
C CRLF + CRLF + CRLF + CRLF +
C '--' + %Trimr(MBoundary)
C* Add attachment file(s) if requested
C If NbrFiles > *Zero
C and AttachFile(1) <> '*NONE'
C Exsr WriteFile
C Do NbrFiles Z 5 0
C Clear SavePos
C Eval Pos = %Scan('/':AttachFile(Z):1)
C Dow Pos > *Zero
C Eval SavePos = Pos
C Eval Pos = %Scan('/':AttachFile(Z):Pos+1)
C Enddo
C If SavePos <> *Zero
C Eval AttachName = %Subst(AttachFile(Z):SavePos+1)
C Else
C Eval AttachName = AttachFile(Z)
C Endif
C Select
C* Attachment is BASE64
C When AttachEncode(Z) = '0'
C Eval Data = CRLF +
C 'Content-Type: application/octet' +
C '-stream; name="' +
C %Trimr(AttachName) + '"' +
C CRLF +
C 'Content-Transfer-Encoding: base64' +
C CRLF +
C 'Content-Disposition: attachment; +
C filename="' + %Trimr(AttachName) + '"' +
C CRLF + CRLF
C Exsr WriteFile
C* Open file
C Eval FullName = %TRIMR(AttachFile(Z)) + Null
C Exsr RtvCodePage
C Eval AttachDesc = open(%ADDR(FullName)
C : O_RDONLY)
C* Read from file, encode BASE64 and write to MIME file
C Eval BytesRead = read(AttachDesc
C : %Addr(DataRead)
C : %Size(DataRead))
C Dow BytesRead > 0
C Eval E_Offset = 1
C Eval Data = %Subst(DataRead:1:BytesRead)
C DoW E_Offset < BytesRead
C If BytesRead-E_Offset+1 < E_Line_Length
C Eval E_Length = BytesRead-E_Offset+1
C Else
C Eval E_Length = E_Line_Length
C EndIf
C Eval E_Line = %Trim(sEncodeLineB64(
C %Subst(Data:E_OffSet:E_Length):E_Length)
C )+CRLF
C Eval BytesWrt = write(FileDesc
C : %ADDR(E_Line)
C : E_Length+2)
C Eval E_Offset = E_Offset + E_Line_Length
C Enddo
C Eval BytesRead = read(AttachDesc
C : %Addr(DataRead)
C : %Size(DataRead))
C Enddo
C* Attachment is MIME
C When AttachEncode(Z) = '1'
C Eval Data = CRLF +
C 'Content-Type: application/octet' +
C '-stream; name="' +
C %Trimr(AttachName) + '"' +
C CRLF +
C 'Content-Transfer-Encoding: 7bit' +
C CRLF +
C 'Content-Disposition: attachment; +
C filename="' + %Trimr(AttachName) + '"' +
C CRLF + CRLF
C Exsr WriteFile
C* Open file
C Eval FullName = %TRIMR(AttachFile(Z)) + Null
C Exsr RtvCodePage
C Eval AttachDesc = open(%ADDR(FullName)
C : O_RDONLY + O_TEXTDATA)
C* Read from file and write to MIME file
C Eval BytesRead = read(AttachDesc
C : %Addr(DataRead)
C : %Size(DataRead))
C Dow BytesRead > 0
C Eval E_Offset = 1
C Eval Data = %Subst(DataRead:1:BytesRead)
C Eval BytesWrt = write(FileDesc
C : %ADDR(Data)
C : %LEN(%TRIMR(Data)))
C Eval BytesRead = read(AttachDesc
C : %Addr(DataRead)
C : %Size(DataRead))
C Enddo
C EndSL
C* Close attachment file and write to MIME
C Eval ReturnInt = close(AttachDesc)
C If Z >= NbrFiles
C Eval Data = CRLF +
C '--' + %Trimr(MBoundary) + '--' +
C CRLF + CRLF
C Else
C Eval Data = CRLF +
C '--' + %Trimr(MBoundary)
C Endif
C Exsr WriteFile
C Enddo
C Else
C* Write end of MIME file for e-mail w/ no attachment
C Eval Data = %Trimr(Data) + '--' + CRLF + CRLF
C Exsr WriteFile
C Endif
C* Close file
C Eval ReturnInt = close(FileDesc)
C*
C Endsr
C*****************************************************************
C* Retrieve code page
C*****************************************************************
CSR RtvCodePage Begsr
C*** Retrieve file attributes
C Eval ReturnInt = stat(%ADDR(FullName):
C %ADDR(StatDS))
C If ReturnInt <> *Zero
C Clear st_codepage
C Endif
C***
C Endsr
C*****************************************************************
C* Write file
C*****************************************************************
CSR WriteFile Begsr
C*** Write to file
C Eval BytesWrt = write(FileDesc
C : %ADDR(Data)
C : %LEN(%TRIMR(Data)))
C***
C Endsr
C*****************************************************************
C* Retrieve day of week
C*****************************************************************
CSR RtvFmtDate Begsr
C*** CONVERT CURRENT DATE TO LILIAN
C MOVE LDate InDate
C CALLB(D) 'CEEDAYS'
C PARM InDate 10
C PARM 'YYYY-MM-DD' InPicture 10
C PARM LilianDate
C PARM FC1
C*** CONVERT LILIAN DATE TO CHARACTER DATE
C EVAL DateFmt = 'Www, DD Mmm YYYY'
C CALLB(D) 'CEEDATE'
C PARM LilianDate
C PARM DateFmt
C PARM DateOut
C PARM FC1
C***
C Endsr
C*****************************************************************
C* Initialization routine
C*****************************************************************
CSR *Inzsr Begsr
C*** Retrieve operating system version
C Eval Retrieve = '*OPSYS *CUR 0000*CODE'
C Call 'QSZRTVPR'
C Parm Receiver
C Parm X'00000080' Rcvlen 4
C Parm 'PRDR0100' Format 8
C Parm Retrieve 27
C Parm X'00000000' ErrorParm 4
C*** Retrieve Coordinated universal time offset
C Call 'QWCRSVAL'
C Parm RtnVal
C Parm LengthB
C Parm NumRtvB
C Parm 'QUTCOFFSET' SystemVal 10
C Parm X'00000000' ErrorParm
C***
C Endsr
C*****************************************************************
* Begin Functions
*---------------------------------------------------------
* Character bitwise NOT
P cNOT B
D Pi Like(TChar)
D factor1 Like(TChar) Value
D Result S Like(TChar)
C Eval Result = x'FF'
C BitOff factor1 Result
C Return Result
P cNOT E
*---------------------------------------------------------
* Character bitwise AND
P cAND B
D Pi Like(TChar)
D factor1 Like(TChar) Value
D factor2 Like(TChar) Value
D nfactor1 S Like(TChar)
D nfactor2 S Like(TChar)
D Result S Like(TChar)
C Eval nfactor1 = cNot(factor1)
C Eval nfactor2 = cNot(factor2)
C Eval Result = x'FF'
C BitOff nfactor1 Result
C BitOff nfactor2 Result
C Return Result
P cAND E
*---------------------------------------------------------
* Character bitwise OR
P cOR B
D Pi Like(TChar)
D factor1 Like(TChar) Value
D factor2 Like(TChar) Value
D Result S Like(TChar)
C Eval Result = x'00'
C BitOn factor1 Result
C BitOn factor2 Result
C Return Result
P cOR E
*---------------------------------------------------------
* TChar bitwise ShiftLeft
P cLShift B
D Pi Like(TChar)
D factor1 Like(TChar) Value
D shiftcount Like(TInt_u) Value
D C S Like(TInt)
D WorkDS DS
D fInt Like(TInt_u)
D RByte Like(TChar) Dim(4) Overlay(fInt)
D Result S Like(TChar)
C Eval RByte = x'00000000'
C Eval RByte(4) = factor1
C Do ShiftCount C
C BitOff '0' RByte(1)
C Eval fInt = fInt * 2
C EndDo
C Eval Result = RByte(4)
C Return Result
P cLShift E
*---------------------------------------------------------
* TChar bitwise ShiftRight
P cRShift B
D Pi Like(TChar)
D factor1 Like(TChar) Value
D shiftcount Like(TInt_u) Value
D WorkDS DS
D fInt Like(TInt_u)
D RByte Like(TChar) Dim(4) Overlay(fInt)
D Result S Like(TChar)
C Eval RByte = x'00000000'
C Eval RByte(4) = factor1
C Eval fInt = fInt / (2**ShiftCount)
C Eval Result = RByte(4)
C Return Result
P cRShift E
*---------------------------------------------------------
* TChar Return Ordinal Value of Character
P cOrd B
D Pi Like(TInt_u)
D factor1 Like(TChar) Value
D WorkDS DS
D fInt Like(TInt_u)
D RByte Like(TChar) Dim(4) Overlay(fInt)
D Result S Like(TInt_u)
C Eval RByte = x'00000000'
C Eval RByte(4) = factor1
C Eval Result = fInt
C Return Result
P cOrd E
*---------------------------------------------------------
* TInt_u bitwise AND
P uAND B Export
D Pi Like(TInt_u)
D factor1 Like(TInt_u) Value
D factor2 Like(TInt_u) Value
D farray1_ptr S Like(TPointer)
D farray2_ptr S Like(TPointer)
D rarray_ptr S Like(TPointer)
D farray1 S Like(TChar) Dim(4) Based(farray1_ptr)
D farray2 S Like(TChar) Dim(4) Based(farray2_ptr)
D rarray S Like(TChar) Dim(4) Based(rarray_ptr)
D C S Like(TInt)
D Result S Like(TInt_u)
C Eval farray1_ptr = %addr(factor1)
C Eval farray2_ptr = %addr(factor2)
C Eval rarray_ptr = %addr(Result)
C Do 4 C
C Eval rarray(c) = cAND(farray1(c):farray2(c))
C EndDo
C Return Result
P uAND E
*---------------------------------------------------------
*// TString Encode Base64
*// Some things to note:
*// Base64 expands 8bits/byte to 6bits/byte so the
*// resulting string will be longer that the input
*// string, i.e. the max possible length of the
*// input string is %LEN(TString)/8*6 = 192
*// This implementation actually uses a input string
*// of max length E_Line_Length=45
P sEncodeLineB64 B
D Pi Like(TString)
D LineIn Like(TString) Value
D SizeInOut Like(TInt_u)
D fInPos S Like(TInt_u)
D fOutPos S Like(TInt_u)
D fOffSet S Like(TInt)
D C S Like(TInt_u)
D Result S Like(TString)
C Eval Result = *Allx'00'
C Eval fInPos = 1
C Eval fOutPos = 1
C Eval fOffSet = 2
*// The following loop does the bitwise BASE64 encoding
*//Example:
*// 11111111 10101010 01010101 will be changed to
*// 00111111 00111010 00101001 00010101
C DoW fInPos <= SizeInOut
C If fOffSet > 0
C Eval %Subst(Result:fOutPos:1) =
C cOr(%Subst(Result:fOutPos:1):
C cRShift(cAnd(%Subst(LineIn:fInPos:1):
C cLShift(x'3F':fOffset)):fOffset))
C Eval fOffset = fOffset -6
C Eval fOutPos = fOutPos + 1
C Else
C If fOffSet < 0
C Eval fOffset = fOffset * -1
C Eval %Subst(Result:fOutPos:1) =
C cOr(%Subst(Result:fOutPos:1):
C cLShift(cAnd(%Subst(LineIn:fInPos:1):
C cRShift(x'3F':fOffset)):fOffset))
C Eval fOffset = 8-fOffset
C Eval fInPos = fInPos + 1
C Else
*
C Eval %Subst(Result:fOutPos:1) =
C cOr(%Subst(Result:fOutPos:1):
C cAnd(%Subst(LineIn:fInPos:1):x'3F'))
C Eval fOffset = 2
C Eval fInPos = fInPos + 1
C Eval fOutPos = fOutPos + 1
C EndIf
C EndIf
C EndDo
*//We repositioned to a new byte in the output stream,
*//but we have not used it yet, so move one back
C If fOffSet = 2
C Eval fOutPos = fOutPos -1
C EndIf
*//This loop replaces the 6bit binary values with the standard
*//characters as per RFC2045
C 1 Do fOutPos C
C Eval %Subst(Result:C:1) =
C %Subst(Bin2Base64:cOrd(%Subst(Result:C:1))
C +1:1)
C EndDo
*//Output Length/4 must be an integer, so add some fillers
C DoW uAnd(fOutPos:3) <> 0
C Eval fOutPos = fOutPos + 1
C Eval %Subst(Result:fOutPos:1) = '='
C EndDo
*//We are returning SizeInOut, so set it to the correct value
C Eval SizeInOut = fOutPos
C Return Result
P sEncodeLineB64 E
*---------------------------------------------------------
* Get Attachment File Name
P AttachFile B
D Pi Like(TString)
D Index Like(TInt) Value
C Eval AttachRec = AttachInfo(Index)
C Return fAttachFile
P AttachFile E
*---------------------------------------------------------
* Get Attachment Encoding Type
P AttachEncode B
D Pi Like(TChar)
D Index Like(TInt) Value
C Eval AttachRec = AttachInfo(Index)
C Return fAttachEncode
P AttachEncode E
*---------------------------------------------------------
* // End Functions
/*********************************************************************/
/* DIRECTIVES- */
/* PARM TEXT('SEND A MIME E-MAIL MESSAGE.') */
/* PARM AUT(*CHANGE) */
/* PARM DFTACTGRP(*NO) */
/* PARM ACTGRP(*CALLER) */
/*********************************************************************/
/* To compile include the parameters: AUT(*CHANGE) */
/* DFTACTGRP(*NO) */
/* ACTGRP(*CALLER) */
/*********************************************************************/
/* PROGRAMMER -D. LELAND */
/* DATE WRITTEN-03/17/1998 */
/*********************************************************************/
/* NARRATIVE- */
/* This program will send a MIME e-mail message. */
/*********************************************************************/
PGM PARM(&ADDRESS &SUBJECT &ATTACHMENT +
&MESSAGE &EMAILTYPE &SENDER)
DCL VAR(&ADDRESS) TYPE(*CHAR) LEN(7847)
DCL VAR(&LIST) TYPE(*CHAR) LEN(7727)
DCL VAR(&SUBJECT) TYPE(*CHAR) LEN(256)
DCL VAR(&ATTACHMENT) TYPE(*CHAR) LEN(7805)
DCL VAR(&ATTACHLIST) TYPE(*CHAR) LEN(7712)
DCL VAR(&FILEATTACH) TYPE(*CHAR) LEN(256)
DCL VAR(&MESSAGE) TYPE(*CHAR) LEN(512)
DCL VAR(&EMAILTYPE) TYPE(*CHAR) LEN(10)
DCL VAR(&SENDER) TYPE(*CHAR) LEN(513)
DCL VAR(&SENDEREA) TYPE(*CHAR) LEN(255)
DCL VAR(&SENDERNM) TYPE(*CHAR) LEN(256)
DCL VAR(&FILENAME) TYPE(*CHAR) LEN(255)
DCL VAR(&SEQNO) TYPE(*CHAR) LEN(3)
DCL VAR(&SEQNO#) TYPE(*DEC) LEN(3 0)
DCL VAR(&CPFID) TYPE(*CHAR) LEN(7)
DCL VAR(&NBRRECIP) TYPE(*DEC) LEN(4 0)
DCL VAR(&NBRATTACH) TYPE(*DEC) LEN(4 0)
DCL VAR(&COUNT) TYPE(*DEC) LEN(4 0)
DCL VAR(&PTR) TYPE(*DEC) LEN(5 0)
DCL VAR(&PTR1) TYPE(*DEC) LEN(5 0)
DCL VAR(&PTR2) TYPE(*DEC) LEN(5 0)
DCL VAR(&RTNVALINT) TYPE(*CHAR) LEN(4)
DCL VAR(&RTNVAL) TYPE(*CHAR) LEN(2)
DCL VAR(&PATH) TYPE(*CHAR) LEN(100)
DCL VAR(&NULL) TYPE(*CHAR) LEN(1) +
VALUE(X'00')
DCL VAR(&BUF) TYPE(*CHAR) LEN(4096)
DCL VAR(&DTAARALIB) TYPE(*CHAR) LEN(10) +
VALUE('QGPL')
DCL VAR(&ERRORSW) TYPE(*LGL)
/*********************************************************************/
/* Global monitor for errors */
/*********************************************************************/
MONMSG MSGID(CPF0000) EXEC(GOTO STDERR1)
/*********************************************************************/
/* Extract parms from cmd list */
/*********************************************************************/
CHGVAR VAR(&NBRRECIP) VALUE(%BIN(&ADDRESS 1 2))
CHGVAR VAR(&PTR1) VALUE((&NBRRECIP * 2) + 3)
CHGVAR VAR(&PTR2) VALUE(&NBRRECIP * 515)
CHGVAR VAR(%SST(&LIST 1 2)) VALUE(%SST(&ADDRESS 1 2))
CHGVAR VAR(%SST(&LIST 3 &PTR2)) VALUE(%SST(&ADDRESS +
&PTR1 &PTR2))
CHGVAR VAR(&SENDEREA) VALUE(%SST(&SENDER 3 255))
CHGVAR VAR(&SENDERNM) VALUE(%SST(&SENDER 258 256))
/*********************************************************************/
/* Check for attachment existence */
/*********************************************************************/
CHGVAR VAR(&NBRATTACH) VALUE(%BIN(&ATTACHMENT 1 2))
CHGVAR VAR(&COUNT) VALUE(0)
CHGVAR VAR(&PTR) VALUE((&NBRATTACH * 2) + 5)
IF COND(%SST(&ATTACHMENT &PTR 256) *NE '*NONE') +
THEN(DO)
SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) +
MSGDTA('Checking for existence of +
attachment(s)...') TOPGMQ(*EXT) +
MSGTYPE(*STATUS)
RETRY: CHGVAR VAR(&FILEATTACH) VALUE(%SST(&ATTACHMENT &PTR +
256))
CHGVAR VAR(&PATH) VALUE(&FILEATTACH *TCAT &NULL)
CALLPRC PRC('stat') PARM(&PATH &BUF) +
RTNVAL(%BIN(&RTNVALINT 1 4))
CHGVAR VAR(&RTNVAL) VALUE(%BIN(&RTNVALINT))
IF COND(&RTNVAL *NE '00') THEN(SNDPGMMSG +
MSGID(CPF9897) MSGF(QCPFMSG) +
MSGDTA('Object ' || &FILEATTACH |< ' not +
found.') TOPGMQ(*SAME) MSGTYPE(*ESCAPE))
CHGVAR VAR(&COUNT) VALUE(&COUNT + 1)
CHGVAR VAR(&PTR) VALUE(&PTR + 259)
IF COND(&COUNT *LT &NBRATTACH) THEN(GOTO +
CMDLBL(RETRY))
ENDDO
/*********************************************************************/
/* Set up ATTACHLIST to contain: */
/* 2 Binary :Number of attachments */
/* (2 Binary :Attachment number */
/* 256 Alpha :Attachment name */
/* 1 Alpha :Attachment type) * max 30 */
/*********************************************************************/
CHGVAR VAR(&NBRATTACH) VALUE(%BIN(&ATTACHMENT 1 2))
CHGVAR VAR(&PTR1) VALUE((&NBRATTACH * 2) + 3)
CHGVAR VAR(&PTR2) VALUE(&NBRATTACH * 259)
CHGVAR VAR(%SST(&ATTACHLIST 1 2)) +
VALUE(%SST(&ATTACHMENT 1 2))
CHGVAR VAR(%SST(&ATTACHLIST 3 &PTR2)) +
VALUE(%SST(&ATTACHMENT &PTR1 &PTR2))
/*********************************************************************/
/* Determine which file sequence number to use next */
/*********************************************************************/
CHKOBJ OBJ(&DTAARALIB/NXTMIME#) OBJTYPE(*DTAARA)
MONMSG MSGID(CPF9801) EXEC(DO)
CRTDTAARA DTAARA(&DTAARALIB/NXTMIME#) TYPE(*CHAR) LEN(3) +
VALUE('000')
ENDDO
RTVDTAARA DTAARA(&DTAARALIB/NXTMIME#) RTNVAR(&SEQNO)
/*********************************************************************/
/* Build name */
/*********************************************************************/
CHGVAR VAR(&FILENAME) VALUE('/TMP/EMHDR' *TCAT +
&SEQNO *TCAT '.TXT')
/*********************************************************************/
/* Update data area w/ next sequence number to use */
/*********************************************************************/
CHGVAR VAR(&SEQNO#) VALUE(&SEQNO)
CHGVAR VAR(&SEQNO#) VALUE(&SEQNO# + 1)
IF COND(&SEQNO# *EQ 999) THEN(CHGVAR +
VAR(&SEQNO) VALUE('000'))
ELSE CMD(CHGVAR VAR(&SEQNO) VALUE(&SEQNO#))
CHGDTAARA DTAARA(&DTAARALIB/NXTMIME#) VALUE(&SEQNO)
/*********************************************************************/
/* Call RPG program to send message */
/*********************************************************************/
IF COND(&EMAILTYPE *EQ '*MIME') THEN(DO)
SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA('Sending +
MIME e-mail...') TOPGMQ(*EXT) +
MSGTYPE(*STATUS)
CALL PGM(SNDEMAILR) PARM(&FILENAME &ATTACHLIST +
&LIST &SUBJECT &MESSAGE &SENDEREA +
&SENDERNM &CPFID)
IF COND(&CPFID *NE ' ') THEN(DO)
SNDPGMMSG MSGID(&CPFID) MSGF(QCPFMSG) TOPGMQ(*SAME) +
MSGTYPE(*ESCAPE)
ENDDO
ENDDO
ELSE CMD(DO)
SNDPGMMSG MSGID(CPF9897) MSGF(QCPFMSG) MSGDTA('This +
e-mail type (' || &EMAILTYPE |< ') is +
currently not supported. Please contact +
the IS department.') TOPGMQ(*SAME) +
MSGTYPE(*ESCAPE)
ENDDO
RETURN
/*********************************************************************/
/* Error handling routine */
/*********************************************************************/
STDERR1: IF COND(&ERRORSW) THEN(SNDPGMMSG MSGID(CPF9999) +
MSGF(QCPFMSG) MSGTYPE(*ESCAPE)) /* +
Function check */
CHGVAR VAR(&ERRORSW) VALUE('1') /* Set to fail if +
error occurs */
/*********************************************************************/
/* Move program messages back to previous level */
/*********************************************************************/
CALL PGM(QMHMOVPM) PARM(' ' '*COMP +
*DIAG *INFO ' X'00000003' *PGMBDY +
X'00000001' X'00000000')
/*********************************************************************/
/* Resend escape messages back to previous level */
/*********************************************************************/
CALL PGM(QMHRSNEM) PARM(' ' X'00000000' +
X'40404040404040404040404040404040000000015+
CD7C7D4C2C4E8404040' X'0000001F' RSNM0200 +
'* ' X'00000000')
ENDPGM
/*********************************************************************/
/* END OF PROGRAM */
/*********************************************************************/
ENDPGM: ENDPGM
/*********************************************************************/
/* DIRECTIVES- */
/* PARM TEXT('Send an E-Mail Message') */
/* PARM PGM(SNDEMAILC) */
/*********************************************************************/
/* To compile include the parameters: PGM(SNDEMAILC) */
/*********************************************************************/
CMD PROMPT('Send an E-mail Message')
PARM KWD(ADDRESSEE) TYPE(ELEM1) MIN(1) MAX(15) +
CHOICE(*NONE) PROMPT('Recipient(s)' 2)
PARM KWD(SUBJECT) TYPE(*CHAR) LEN(256) DFT(*NONE) +
SPCVAL((*NONE '')) EXPR(*YES) +
PROMPT('Subject')
PARM KWD(ATTACHMENT) TYPE(ELEM3) +
SNGVAL((*NONE)) MAX(30) +
PROMPT('File attachment')
PARM KWD(MESSAGE) TYPE(*CHAR) LEN(512) +
DFT(*NONE) SPCVAL((*NONE '')) EXPR(*YES) +
PROMPT('Message')
PARM KWD(EMAILTYPE) TYPE(*CHAR) LEN(10) +
DFT(*MIME) EXPR(*YES) PROMPT('E-mail type' 1)
PARM KWD(SENDER) TYPE(ELEM2) DFT(*SYSTEM) +
SNGVAL((*SYSTEM +
'systemadmin@harter.com')) PROMPT('Sender' 3)
ELEM1: ELEM TYPE(*PNAME) LEN(256) MIN(1) EXPR(*YES) +
PROMPT('E-mail address of recipient')
ELEM TYPE(*CHAR) LEN(256) DFT(*NONE) +
SPCVAL((*NONE '')) EXPR(*YES) +
PROMPT('Name of e-mail recipient')
ELEM TYPE(*CHAR) LEN(1) DFT(*PRI) SPCVAL((*PRI +
'0') (*CC '1') (*BCC '2')) EXPR(*YES) +
PROMPT('Recipient type')
ELEM2: ELEM TYPE(*PNAME) LEN(255) EXPR(*YES) +
PROMPT('E-mail address of sender')
ELEM TYPE(*CHAR) LEN(256) EXPR(*YES) PROMPT('Name +
of e-mail sender')
ELEM3: ELEM TYPE(*PNAME) LEN(256) DFT(*NONE) EXPR(*YES) +
PROMPT('File Name')
ELEM TYPE(*CHAR) LEN(1) DFT(*BASE64) +
SPCVAL((*BASE64 '0') (*MIME '1')) +
EXPR(*YES) PROMPT('Encoding Type')
|