/lib/mailUtils.tcl
TCL | 170 lines | 135 code | 9 blank | 26 comment | 12 complexity | beeb449d23bbbe3d4c649a275237a4a4 MD5 | raw file
1############################################################################ 2# Copyright (C) 2008 Alexander Galanin <gaa.nnov@mail.ru> # 3# # 4# This program is free software: you can redistribute it and/or modify # 5# it under the terms of the GNU Lesser General Public License as # 6# published by the Free Software Foundation, either version 3 of the # 7# License, or (at your option) any later version. # 8# # 9# This program is distributed in the hope that it will be useful, # 10# but WITHOUT ANY WARRANTY; without even the implied warranty of # 11# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # 12# GNU General Public License for more details. # 13# # 14# You should have received a copy of the GNU Lesser GNU General Public # 15# License along with this program. # 16# If not, see <http://www.gnu.org/licenses/>. # 17############################################################################ 18 19package provide mailUtils 1.0 20 21package require Tcl 8.4 22package require htmlparse 1.1 23 24namespace eval mailUtils { 25 26namespace export \ 27 makeReplyHeader \ 28 quoteText \ 29 makeReply 30 31# 32# makeReply - Make header with "Re:" prefix 33# 34proc makeReplyHeader {header} { 35 set re {^re(?:\^(\d+)|()):\s+} 36 set count 0 37 38 while { [ regexp -nocase -lineanchor -- $re $header dummy c ] != 0 } { 39 if { $c == "" } { 40 set c 1 41 } 42 incr count $c 43 regsub -nocase -lineanchor -- $re $header {} header 44 } 45 46 if { $count != 0 } { 47 return "Re^[ expr $count + 1 ]: $header" 48 } else { 49 return "Re: $header" 50 } 51} 52 53# 54# quoteText - Put text into ">" quotes 55# 56proc quoteText {text} { 57 set res "" 58 foreach line [ split $text "\n" ] { 59 if { [ string trim $line ] != "" } { 60 if { [ string compare -length 1 $line ">" ] == 0 } { 61 lappend res ">$line" 62 } else { 63 lappend res "> $line" 64 } 65 } 66 } 67 return [ join $res "\n\n" ] 68} 69 70# 71# htmlToText - convert LOR-style HTML to text 72# 73proc htmlToText {text} { 74 foreach {re s} { 75 {<img src="/\w+/\w+/votes\.gif"[^>]*>} "\[\\&\]" 76 "<img [^>]*?>" "[image]" 77 "<!--.*?-->" "" 78 "<tr>" "\n" 79 "</tr>" "" 80 "</{0,1}table>" "" 81 "</{0,1}td(?: colspan=\\d+){0,1}>" " " 82 "</{0,1}pre>" "" 83 "\n<br>" "\n" 84 "<br>\n" "\n" 85 "<br>" "\n" 86 "<p>" "\n" 87 "</p>" "" 88 "<a href=\"([^\"]+)\"[^>]*>[^<]*</a>" "\\1" 89 "</{0,1}i>" "" 90 "</{0,1}(?:u|o)l>" "" 91 "<li>" "\n * " 92 "</li>" "" 93 "\n{3,}" "\n\n" } { 94 regsub -all -nocase -- $re $text $s text 95 } 96 return [ ::htmlparse::mapEscapes $text ] 97} 98 99# 100# makeReplyToMessage - Make reply to specified message 101# 102# letter - original letter 103# from - string to substitute into From header 104# headers - (optional) additional headers 105# 106proc makeReplyToMessage {letter from {headers ""}} { 107 set res "" 108 array set tmp { 109 From "" 110 To "" 111 In-Reply-To "" 112 Message-ID "" 113 Subject "" 114 Content-Type "text/html" 115 body "" 116 } 117 foreach {h v} [ concat $letter $headers ] { 118 if { [ lsearch [ array names tmp ] $h ] >= 0 } { 119 set tmp($h) $v 120 } else { 121 lappend res $h $v 122 } 123 } 124 lappend res From $from 125 lappend res To $tmp(From) 126 lappend res In-Reply-To $tmp(Message-ID) 127 if { $tmp(Content-Type) == "text/html" } { 128 set subj [ htmlToText $tmp(Subject) ] 129 set body [ htmlToText $tmp(body) ] 130 } else { 131 set subj $tmp(Subject) 132 set body $tmp(body) 133 } 134 #TODO: will be removed in v1.2 135 lappend res Subject [ makeReplyHeader $subj ] 136 lappend res Content-Type "text/plain" 137 lappend res body [ quoteText $body ] 138 array unset tmp 139 140 return $res 141} 142 143# 144# getMailHeaders - Get specified headers from letter as list. 145# If header does not present in text, it will be 146# substituded as "" 147# 148# letter - message to process 149# headers - list of headers 150# 151proc getMailHeaders {letter headers} { 152 array set arr "" 153 foreach h $headers { 154 set arr($h) "" 155 } 156 foreach {h v} $letter { 157 if { [ lsearch -exact $headers $h ] >= 0 } { 158 set arr($h) $v 159 } 160 } 161 set res "" 162 foreach h $headers { 163 lappend res $arr($h) 164 } 165 array unset arr 166 return $res 167} 168 169} 170