REBOL [
	Title: "Patches to the mail subsystem"
	Date: 2003-03-23
  Author: "Ingo Hohmann"
  Email: ingo@h-o-h.org
	Purpose: {Make Rebol mail handling more standards complient}
	Comment: {
		While I believe the old patches to be pretty stable, I have quite
		some changes in this updated version. So I'd say some testing is
		needed first.
		}
  History: [
		[2003-04-01  "iho" {doesn't choke on missing email address}]
		[23-03-2003  "IHO" {Now based on the 2.5.5 core functionality}]
    [07-05-2001  "iho" {corrected a bug found by Tengo <mnpotl@yahoo.com>
      script didn't work, when a header string ended with newline} ]
    [22-Nov-1999 "iho" {always close smtp-port}
      {multiline header fields are started with " "}]
    [17-Nov-1999 "iho" {"^/." lines are escaped with "^/.."} ]
    [16-Nov-1999 "iho" {bcc/cc are handled} ]
    [11-Nov-1999 "iho" {address block of the form [ [name] email ... ]
         may now be used (name may be omitted).}
      {Now address blocks in header-objects are interpreted correctly}]
    [13-Sep-1999 "iho" {Added send "REALNAME <email@domain>" message
                   and Signature (to be set in system/user/signature)}]
    [6-Sep-1999 "iho" {re-introduced my original version, you
        may just move the comment mark, if you wish}]
      [31-Aug-1999 "Allen Kamp" {Modified From output to include ""
         as in "User Name" <user@wherever.com>}]
    [8-Aug-1999 "iho" {Original Release} ]
  ]
]

send: func [
	{
		Send a message to an address (or block of addresses)
		*PATCHED* (iho) real names are shown, use
		send ["name" email@host.dom ...] "message" 
		} 
	address [email! block!] "An address or block of addresses" 
	message "Text of message. First line is subject." 
	/only "Send only one message to multiple addresses" 
	/header "Supply your own custom header" 
	header-obj [object!] "The header to use" 
	/attach "Attach file, files, or [.. [filename data]]" 
	files [file! block!] "The files to attach to the message" 
	/subject "Set the subject of the message" 
	subj "The subject line" 
	/show "Show all recipients in the TO field" 
	/local smtp-port content do-send boundary make-boundary tmp from
][
	make-boundary: does [] 
	do-send: func [port data] [
		foreach item reduce data [
			if string? item [replace/all item "^/." "^/.."]
		] 
		insert port reduce data
	] 
	if file? files [files: reduce [files]] 
	if email? address [address: reduce [address]] 

	; should mold/all be used? ... maybe not, because of problems with older Rebols
	message: either string? message [copy message] [mold message] 

	either header [
		; be sure not to change the original object
		header-obj: make header-obj []
	][
		header-obj: make system/standard/email [
			; not optimal, what if the first newline occurs after 20000 characters???? 
		]
	] 
	either subject [
		header-obj/subject: subj
	][ 
		header-obj/subject: any [subj copy/part message any [find message newline 50]]
	]

	either none? header-obj/from [
		if none? header-obj/from: from: system/user/email [net-error "Email header not set: no from address"] 
		if all [string? system/user/name not empty? system/user/name] [
			header-obj/from: rejoin [system/user/name " <" from ">"]
		]
	] [
		from: header-obj/from
	] 

	; to is set from header-obj, but sent according to address? ... strange!

	address: copy address

	either none? header-obj/to [
		header-obj/to: make string! 20
	][
		either block? header-obj/to [
			insert tail address header-obj/to
		][
			insert tail address mail-list-rules/parse-mail-list form header-obj/to
		]
	]

	if show [
		header-obj/to: net-utils/create-address-line address
	]

	either block? header-obj/cc [
		insert tail address header-obj/cc
		header-obj/cc: net-utils/create-address-line header-obj/cc
	][
		if not none? header-obj/cc [
			insert tail address mail-list-rules/parse-mail-list form header-obj/cc
		]
	]

	if not show [
		header-obj/cc: none
	]

	either block? header-obj/bcc [
		insert tail address header-obj/bcc
	][
		if not none? header-obj/bcc [
			insert tail address mail-list-rules/parse-mail-list form header-obj/bcc
		]
	]
	
	if none? header-obj/date [header-obj/date: to-idate now] 
	if attach [
		boundary: rejoin ["--__REBOL--" system/product "--" system/version "--" checksum form now/precise "__"] 
		header-obj/MIME-Version: "1.0" 
		header-obj/content-type: join "multipart/mixed; boundary=" [{"} skip boundary 2 {"}] 
		message: build-attach-body message files boundary
	] 

	if error? err: try [
		smtp-port: open [scheme: 'smtp] 
		either only [
			do-send smtp-port ["MAIL FROM: <" from ">"] 
			foreach addr address [
				if email? addr [
					do-send smtp-port ["RCPT TO: <" addr ">"]
				]
			] 
			insert insert message net-utils/export header-obj newline 
			do-send smtp-port ["DATA" message]
		] [
			foreach addr address [
				if email? addr [
					do-send smtp-port ["MAIL FROM: <" from ">"] 
					do-send smtp-port ["RCPT TO: <" addr ">"] 
					if not show [insert clear header-obj/to addr] 
					content: rejoin [net-utils/export header-obj newline message] 
					do-send smtp-port ["DATA" content]
				]
			]
		]
	][ ; close smtp-port, even if error, throw error again
		close smtp-port
		print "While trying to send email:"
		err
	]
	close smtp-port
]

; scan email address headers, and give back a block of
; realname/email pairs, or email only
Mail-List-Rules: make object! [
	addr-list: none
	addy: none
	addr: none
	name: none
	mailbox: [
		copy addy [to "," | to ";" | to end] (
			if not none? addy [
				parse addy [
					"(" copy name to ")" skip copy addr |
					{"} copy name to {"} thru "<" copy addr to ">" |
					copy name to "<" skip copy addr to ">" skip |
					copy addr to "(" skip copy name to ")" skip |
					copy addr to end
				]
			]
		)
	]
	maillist: [
		mailbox
		(
			if not none? name [
				append addr-list trim name
			]
			; Missing email address ... just adding a false address ... is this the best way to go?
			either none? addr [
				append addr-list nobody@localhost
			][
				append addr-list to-email trim addr
			]
		)
		[[thru "," | thru ";"] maillist | none]
	]
	parse-mail-list: func [
		{Mail-List-Rules *PATCHED* (iho)}
		data [string!]
	][
		addr-list: make block! 1
		parse data maillist
		addr-list
	]
]

; original Rebol does not take care to have multilines strarting with a space/tab in front
; of subsequent lines, now we can read those false headers
; possibility to read a mail in mbox format (starts with "From ...")
header-rules: make object! [
	name: none
	full-line: none
	template: none
	head-list: none
	w: none
	spot: none
	curr-header: none
	dummy: none
	field-chars: make bitset! #{
		000000000060FF03FEFFFF87FEFFFF0700000000000000000000000000000000
		}
	head-line: [
		copy name some field-chars ":" [some " " | none]
		copy line to newline
		(
			w: make word! name
			either not all [template spot: find head-list to set-word! w] [
				insert spot: tail head-list make set-word! name
				insert next spot curr-line: trim any [line ""]
			][
				if string? second spot [
					change/only next spot head insert copy [] second spot
				]
				insert tail second spot curr-line: trim any [line ""]
			]
		)
		newline
	]
	cont-line: [
		copy line to newline (
			insert tail curr-line join " " trim any [line ""]
		)
		newline
	]
	header: [
		[head-line | cont-line ] header | thru newline
	]
	
	content: [
		full-line: (insert insert tail head-list make set-word! "content" full-line) 
		to end
	]
	mbox-header: [["From " thru newline] | none ]
	
	parse-head: func [
		parent [object! none!] 
		data [any-string!] 
		/multiple
	][
		head-list: make block! 10 
		template: all [multiple parent] 
		if not parse/all data [mbox-header header content] [
			net-error "header not correctly parsed"
		] 
		make either parent [parent] [object!] head-list
	]
]

; Now headers will get a tab character
; at the start of subsequent lines
; and creates something that looks like a valid mail
net-utils: make net-utils [
	create-address-line: func [
		{
			Takes a block of optional real names and email addresses, and creates a header string
			*ADDED* (iho)
			}
		addresses [string! block! none!]
		/local result
	][
		result: make string! 20
		either block? addresses [
			while [not tail? addresses] [
				either email? first addresses [
					insert tail result rejoin [either empty? result [""][",^/^- "] first addresses ]
				][
					if all [string? first addresses email? pick addresses 2][
						insert tail result rejoin [either empty? result [""][",^/^- "] first addresses " <" second addresses ">"]
						addresses: next addresses
					]
				]
				addresses: next addresses
			]
			result
		][
			either string? addresses [
				addresses
			][
				""
			]
		]
	]

  export: func [
    {
			Export an object to something that looks like an email
			*PATCHED* (iho) starts multiline lines with a tab
			takes care of real-names, and content
      }
    header-object [object!] "Object to export"
    /local multi-line-rule header-list result space mark1 mark2
  ][
		header-object: make header-object []
		space: charset [#" " #"^-"]
    multi-line-rule: [
      any [
        thru "^/" mark1:
				[
					end (remove back mark1)
					| any space mark2: (change/part mark1 "^-" mark2) :mark1
				]
      ]
      to end
    ]
		header-list: third header-object
		repeat header [from: to: cc: sender:] [
			if block? data: select header-list header [
				change next find header-list header create-address-line data
			]
		]
		if pos: find header-list to set-word! 'content [
			remove/part pos 2
		]
    result: make string! (10 * length? header-list)
    foreach [word value] header-list [
			;if not equal? 'content word [
				if found? value [
					either block? value [
						foreach line value [
							parse line multi-line-rule
							insert tail result reduce [form word ": " line newline ]
						]
					][
						value: form value
						parse value multi-line-rule
						insert tail result reduce [form word ": " value newline ]
					]
				]
			;]
		]
		; OK, if you want the content that's in the header, it's up to you ...
		;if in header-object 'content [
		;	insert tail result newline
		;	insert tail result header-object/content
		;]
    result
  ]
]

; shouldn't /multiple be the default?
import-email: func [
	{
		Constructs an email object from an email message.
		*PATCHED* (iho) added /multiple
		}
	data [string!] "The email message"
	/multiple "Allow multiple occurrences of a header field"
	/local content header
][
	header: copy/part data content: any [find/tail data "^/^/" ""] 
	data: either multiple [
		parse-header/multiple system/standard/email header
	][
		parse-header system/standard/email header
	]
	data/date: parse-header-date data/date 
	data/from: parse-email-addrs data/from 
	data/to: parse-email-addrs data/to 
	data/reply-to: parse-email-addrs data/reply-to 
	data/content: copy content 
	data
]