Annotation of /trunk/openisis/tcl/md

#!/opt/bin/tspr
<%--
        test Tcl server page
        $Id: md,v 1.3 2003/06/10 11:02:47 kripke Exp $
--%><%!

package require mime;
namespace import ::mime::*;

# return list file from date subject size content-type
proc mscan file {
        array set a {from {} date {} subject {} content-type {}}
        set fid [open $file]
        # for quick scan, ignore continuation lines and repeated headers
        while {[gets $fid line]} {
                if [regexp {^([\w\-]+):\s*(.*)} $line - key val] {
                        set a([string tolower $key]) $val
                }
        }
        close $fid
        list $file $a(from) $a(date) $a(subject) [file size $file] $a(content-type)
}

# return list file from date subject size encoding content params parts msg
proc mparse file {
        set l [list $file]
        set msg [initialize -file $file]
        # mime want's whole messages

        # headers
        foreach key {From Date Subject} {
                if [catch {getheader $msg $key} value] {
                        lappend l {}
                } else {
                        lappend l $value
                }
        }
        # properties (parsed content-* headers)
        foreach key {size encoding content params parts} {
                if [catch {getproperty $msg $key} value] {
                        lappend l {}
                } else {
                        lappend l $value
                }
        }
        lappend l $msg
        return $l
}

%><%
        # request standard tags
        # -10 SCRIPT_NAME
        # -11 PATH_INFO
        # -12 REMOTE_USER
        #
        # request parameters
        # 1 move destination (checkbox)
        # 2 the ok button
        # 3 write to
        # 4 write subject
        # 5 write body
        #
        global env
        # foreach e [array names env] { ::puts stderr "$e\t$env($e)" }
        ::puts stderr [request serialize]

        set script [lindex [request get -10] 0]
        set path [lindex [request get -11] 0]
        set user [lindex [request get -12] 0]
        set body [lindex [request get 5] 0]

        if {"" == $user} return
        set l [string length $user]
        set fid [open /var/qmail/users/popasswd]
        while {[gets $fid line]} {
                if ![string match "$user:*" $line] continue
                set upignh [split $line :]
                set name [lindex $upignh 4]
                set base [lindex $upignh 5]/Maildir
                break
        }
        close $fid
        cd $base
        ::puts stderr [pwd]

        if ![regexp {^/(\w+)(/\d+[\w.:,]*)?$} $path - dir file] {
                set dir new
                set file ""
                set rel $script/
        } elseif {"" == $file} {
                set rel ""
        } else {
                set rel ../
        }
        if ![file isdirectory $dir] return
        # scan for dirs
        set dirs {} ;# dirs to list
        set mvdirs {} ;# dirs to move to
        foreach d [glob ???] {
                if ![file isdirectory $d] continue
                switch -- $d tmp {} default { lappend dirs $d }
                switch -- $d new - tmp - uns - out - $dir {} default { lappend mvdirs $d }
        }
        if {"" != $body && [catch { # send
                set to [lindex [request get 3] 0]
                set subject [lindex [request get 4] 0]
                if {"" == $to} { # get from message
                        set msg [initialize -file $dir$file]
                        if [catch {getheader $msg Reply-To} to] {
                                set to [getheader $msg From]
                        }
                        set to [lindex $to 0]
                        if {"" == $subject} {
                                set subject "Re: [lindex [getheader $msg Subject] 0]"
                        }
                        finalize $msg
                }
                set tim [clock seconds]
                set gtf [clock format $tim -format %Y%m%d%H%M%S -gmt 1]
                set rfc [clock format $tim -format {%a, %d %b %Y %H:%M:%S %Z}]
                set fid [open uns/$gtf.[pid] w]
                set msg [initialize -canonical text/plain \
                        -header [list Return-Path $name] \
                        -header [list From $name] \
                        -header [list To $to] \
                        -header [list Date $rfc] \
                        -header [list Subject $subject] \
                        -encoding quoted-printable \
                        -string $body ]
                copymessage $msg $fid
                close $fid
        }]} {
                global errorInfo
                ::puts stderr $errorInfo
        }
%><html>
<head>
</head>
<body>
<%"name%>/<%=dir%>
list: 
<%
        foreach d $dirs {
%>
                <a href="<%=$rel$d%>"><%=d%></a>
<%
        }
%>
<%-- main display --%>
<form action="<%=$rel$dir$file%>" method="POST">
<table>
<%
if {"" == $file} {
%>
        <tr>
                <th>
<%
        foreach d $mvdirs { %><%=d%>&nbsp;<% }
%>
                </th>
                <th>
                From</th>
                <th>Date</th>
                <th>Size</th>
                <th>Subject</th>
        </tr>
<%
        foreach mv [request get 1] {
                ::puts stderr $mv
                if [regexp {^(\w\w\w)/(\S*)$} $mv - dest file] {
                        file rename $dir/$file $dest
%>
        <tr>
        <td>moved</td>
        <td><%"file%></td>
        <td>to</td>
        <td><%"dest%></td>
        </tr>
<%
                }
        }
        cd $dir
        foreach f [glob *] {
                # file from date subject size content-type
                set l [mscan $f]
%>
        <tr>
                <td>
<%
                foreach d $mvdirs {
%>
        <input type="checkbox" name="1" value="<%=d%>/<%?lindex $l 0%>"/>
<%
                }
%>
                </td>
                <td><%"lindex $l 1%></td>
                <td><%"lindex $l 2%></td>
                <td><%"lindex $l 4%></td>
                <td><a href="<%=dir%>/<%?lindex $l 0%>"><%"lindex $l 3%></a></td>
        </tr>
<%
        }
} else { # file view
        set msg [initialize -file $dir$file]
        foreach h [getheader $msg -names] {
                foreach v [getheader $msg $h] {
%>
        <tr>
                <td><%"h%></td>
                <td><%"v%></td>
        </tr>
<%
                }
        }
        set tpart ""
        if {"text/plain" == [getproperty $msg content]} {
                set tpart $msg
        } elseif {![catch {set parts [getproperty $msg parts]}]} {
                foreach p $parts {
                        set ct [getproperty $p content]
%>
        <tr>
                <td>part</td>
                <td><%"ct%></td>
        </tr>
<%
                        if {"text/plain" == $ct} {
                                set tpart $p
                        }
                }
        }
        if {"" != $tpart} {
%>
        <tr><td colspan="2"><pre>
        <%"getbody $tpart%>
        </pre></td></tr>
<%
        }
}
%>
</table>
<input type="submit" name="2" value="ok"/>
<%-- send form --%>
<table>
        <tr><td>to</td><td><input type="text" name="3" size="64"/></td></tr>
        <tr><td>subject</td><td><input type="text" name="4" size="64"/></td></tr>
        <tr><td colspan="2">
                <textarea name="5" width="78" rows="20" cols="78"></textarea>
        </td></tr>
</table>
</form>
</body>
</html>
1	dpavlin	237	#!/opt/bin/tspr
2			<%--
3			test Tcl server page
4			$Id: md,v 1.3 2003/06/10 11:02:47 kripke Exp $
5			--%><%!
6
7			package require mime;
8			namespace import ::mime::*;
9
10			# return list file from date subject size content-type
11			proc mscan file {
12			array set a {from {} date {} subject {} content-type {}}
13			set fid [open $file]
14			# for quick scan, ignore continuation lines and repeated headers
15			while {[gets $fid line]} {
16			if [regexp {^([\w\-]+):\s(.)} $line - key val] {
17			set a([string tolower $key]) $val
18			}
19			}
20			close $fid
21			list $file $a(from) $a(date) $a(subject) [file size $file] $a(content-type)
22			}
23
24			# return list file from date subject size encoding content params parts msg
25			proc mparse file {
26			set l [list $file]
27			set msg [initialize -file $file]
28			# mime want's whole messages
29
30			# headers
31			foreach key {From Date Subject} {
32			if [catch {getheader $msg $key} value] {
33			lappend l {}
34			} else {
35			lappend l $value
36			}
37			}
38			# properties (parsed content-* headers)
39			foreach key {size encoding content params parts} {
40			if [catch {getproperty $msg $key} value] {
41			lappend l {}
42			} else {
43			lappend l $value
44			}
45			}
46			lappend l $msg
47			return $l
48			}
49
50			%><%
51			# request standard tags
52			# -10 SCRIPT_NAME
53			# -11 PATH_INFO
54			# -12 REMOTE_USER
55			#
56			# request parameters
57			# 1 move destination (checkbox)
58			# 2 the ok button
59			# 3 write to
60			# 4 write subject
61			# 5 write body
62			#
63			global env
64			# foreach e [array names env] { ::puts stderr "$e\t$env($e)" }
65			::puts stderr [request serialize]
66
67			set script [lindex [request get -10] 0]
68			set path [lindex [request get -11] 0]
69			set user [lindex [request get -12] 0]
70			set body [lindex [request get 5] 0]
71
72			if {"" == $user} return
73			set l [string length $user]
74			set fid [open /var/qmail/users/popasswd]
75			while {[gets $fid line]} {
76			if ![string match "$user:*" $line] continue
77			set upignh [split $line :]
78			set name [lindex $upignh 4]
79			set base [lindex $upignh 5]/Maildir
80			break
81			}
82			close $fid
83			cd $base
84			::puts stderr [pwd]
85
86			if ![regexp {^/(\w+)(/\d+[\w.:,]*)?$} $path - dir file] {
87			set dir new
88			set file ""
89			set rel $script/
90			} elseif {"" == $file} {
91			set rel ""
92			} else {
93			set rel ../
94			}
95			if ![file isdirectory $dir] return
96			# scan for dirs
97			set dirs {} ;# dirs to list
98			set mvdirs {} ;# dirs to move to
99			foreach d [glob ???] {
100			if ![file isdirectory $d] continue
101			switch -- $d tmp {} default { lappend dirs $d }
102			switch -- $d new - tmp - uns - out - $dir {} default { lappend mvdirs $d }
103			}
104			if {"" != $body && [catch { # send
105			set to [lindex [request get 3] 0]
106			set subject [lindex [request get 4] 0]
107			if {"" == $to} { # get from message
108			set msg [initialize -file $dir$file]
109			if [catch {getheader $msg Reply-To} to] {
110			set to [getheader $msg From]
111			}
112			set to [lindex $to 0]
113			if {"" == $subject} {
114			set subject "Re: [lindex [getheader $msg Subject] 0]"
115			}
116			finalize $msg
117			}
118			set tim [clock seconds]
119			set gtf [clock format $tim -format %Y%m%d%H%M%S -gmt 1]
120			set rfc [clock format $tim -format {%a, %d %b %Y %H:%M:%S %Z}]
121			set fid [open uns/$gtf.[pid] w]
122			set msg [initialize -canonical text/plain \
123			-header [list Return-Path $name] \
124			-header [list From $name] \
125			-header [list To $to] \
126			-header [list Date $rfc] \
127			-header [list Subject $subject] \
128			-encoding quoted-printable \
129			-string $body ]
130			copymessage $msg $fid
131			close $fid
132			}]} {
133			global errorInfo
134			::puts stderr $errorInfo
135			}
136			%><html>
137			<head>
138			</head>
139			<body>
140			<%"name%>/<%=dir%>
141			list:
142			<%
143			foreach d $dirs {
144			%>
145			<a href="<%=$rel$d%>"><%=d%></a>
146			<%
147			}
148			%>
149			<%-- main display --%>
150			<form action="<%=$rel$dir$file%>" method="POST">
151			<table>
152			<%
153			if {"" == $file} {
154			%>
155			<tr>
156			<th>
157			<%
158			foreach d $mvdirs { %><%=d%> <% }
159			%>
160			</th>
161			<th>
162			From</th>
163			<th>Date</th>
164			<th>Size</th>
165			<th>Subject</th>
166			</tr>
167			<%
168			foreach mv [request get 1] {
169			::puts stderr $mv
170			if [regexp {^(\w\w\w)/(\S*)$} $mv - dest file] {
171			file rename $dir/$file $dest
172			%>
173			<tr>
174			<td>moved</td>
175			<td><%"file%></td>
176			<td>to</td>
177			<td><%"dest%></td>
178			</tr>
179			<%
180			}
181			}
182			cd $dir
183			foreach f [glob *] {
184			# file from date subject size content-type
185			set l [mscan $f]
186			%>
187			<tr>
188			<td>
189			<%
190			foreach d $mvdirs {
191			%>
192			<input type="checkbox" name="1" value="<%=d%>/<%?lindex $l 0%>"/>
193			<%
194			}
195			%>
196			</td>
197			<td><%"lindex $l 1%></td>
198			<td><%"lindex $l 2%></td>
199			<td><%"lindex $l 4%></td>
200			<td><a href="<%=dir%>/<%?lindex $l 0%>"><%"lindex $l 3%></a></td>
201			</tr>
202			<%
203			}
204			} else { # file view
205			set msg [initialize -file $dir$file]
206			foreach h [getheader $msg -names] {
207			foreach v [getheader $msg $h] {
208			%>
209			<tr>
210			<td><%"h%></td>
211			<td><%"v%></td>
212			</tr>
213			<%
214			}
215			}
216			set tpart ""
217			if {"text/plain" == [getproperty $msg content]} {
218			set tpart $msg
219			} elseif {![catch {set parts [getproperty $msg parts]}]} {
220			foreach p $parts {
221			set ct [getproperty $p content]
222			%>
223			<tr>
224			<td>part</td>
225			<td><%"ct%></td>
226			</tr>
227			<%
228			if {"text/plain" == $ct} {
229			set tpart $p
230			}
231			}
232			}
233			if {"" != $tpart} {
234			%>
235			<tr><td colspan="2"><pre>
236			<%"getbody $tpart%>
237			</pre></td></tr>
238			<%
239			}
240			}
241			%>
242			</table>
243			<input type="submit" name="2" value="ok"/>
244			<%-- send form --%>
245			<table>
246			<tr><td>to</td><td><input type="text" name="3" size="64"/></td></tr>
247			<tr><td>subject</td><td><input type="text" name="4" size="64"/></td></tr>
248			<tr><td colspan="2">
249			<textarea name="5" width="78" rows="20" cols="78"></textarea>
250			</td></tr>
251			</table>
252			</form>
253			</body>
254			</html>