/[webpac]/trunk/openisis/tcl/md
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Annotation of /trunk/openisis/tcl/md

Parent Directory Parent Directory | Revision Log Revision Log


Revision 239 - (hide annotations)
Mon Mar 8 17:49:13 2004 UTC (17 years, 7 months ago) by dpavlin
File size: 5315 byte(s)
including openisis 0.9.0 into webpac tree

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%>&nbsp;<% }
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>

Properties

Name Value
svn:executable

  ViewVC Help
Powered by ViewVC 1.1.26