/lib/mailUtils.tcl

  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