source: FOIAVistA/trunk/r/MAILMAN-XM/XMRPOP.m@ 1397

Last change on this file since 1397 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 7.4 KB
Line 
1XMRPOP ;ISC-SF/GMB-POP3 Server (RFC 1939) ;05/20/2002 07:05
2 ;;8.0;MailMan;;Jun 28, 2002
3 ; Replaces the class III routines ^XMRPOPA, ^XMRPOPB, ^XMRPOPC,
4 ; which were written by Chiao-Ming Wu, WASH-ISC.
5 ;
6 ; Implements RFC 1939 (replaces RFC 1725)
7 ; Post Office Protocol - Version 3 (POP3) maildrop service
8 ;
9 ; Rather than locking the user's IN basket, which severely disrupts
10 ; mail delivery, we take a snapshot of it, and keep the snapshot in
11 ; a temp global. We then use the temp global during the session.
12 ; Here is the layout of the global:
13 ;
14 ; ^TMP("XM",$J,"POP3")=# msgs^# octets ; total msgs in IN basket
15 ; ; (updated if msgs are deleted)
16 ; ^TMP("XM",$J,"POP3",1)=XMZ^# octets ; msgs 1 thru n are in
17 ; ... ; IN basket.
18 ; ^TMP("XM",$J,"POP3",i)=XMZ^# octets ;
19 ; ^TMP("XM",$J,"POP3",j)=XMZ^# octets ;
20 ; ... ;
21 ; ^TMP("XM",$J,"POP3",n)=XMZ^# octets ;
22 ; ;
23 ; ^TMP("XM",$J,"POP3","D",i)=XMZ ; user deleted msg i
24 ; ^TMP("XM",$J,"POP3","D",j)=XMZ ; user deleted msg j
25ENTRY ;
26 N XMK,XMSTATE,XMCMDS,XMCMD,XMDUZ,XMACCESS,XMVERIFY,XMTRY,XMTMSGS,XMTOCTS,XMV
27 I '$D(ZTQUEUED) S X=$S($D(^%ZOSF("ERRTN")):^("ERRTN"),1:"ERR^ZU"),@(^%ZOSF("TRAP"))
28 I '$G(DUZ) S DUZ=.5
29 I '$D(XMDUZ) S XMDUZ=DUZ
30 I '$D(XMC("BATCH")) S XMC("BATCH")=0
31 I $S('$D(XMCHAN):1,XMCHAN="":1,1:0) S XMCHAN="TCP/IP-MAILMAN"
32 D OPEN^XML
33 I $G(ER)=1 D ^%ZISC:IO'=$G(IO(0)) W !,"Device open failed !",$C(7) Q
34 S:'$D(XM) XM=""
35 I 'XMC("BATCH") X ^%ZOSF("EOFF") S X=255 X ^%ZOSF("RM"),^%ZOSF("TYPE-AHEAD")
36 S ER=0
37 S XMK=1
38 S XMSG="+OK "_^XMB("NETNAME")_" POP3 server ready (Comments to: POSTMASTER@"_^XMB("NETNAME")_")" X XMSEN Q:ER
39 S XMCMDS("AUTH")="^PASS^QUIT^USER^"
40 S XMCMDS("TRAN")="^DELE^LIST^NOOP^QUIT^RETR^RSET^STAT^TOP^UIDL^"
41 S XMSTATE="AUTH"
42 F X XMREC Q:ER D Q:XMCMD="QUIT"!ER
43 . I XMRG="" S ER=1,XMCMD="" Q
44 . S XMCMD=$P(XMRG," ",1)
45 . I $L(XMCMD)<3!($L(XMCMD)>4)!(XMCMD'?.U) S XMSG="-ERR no such command" X XMSEN Q
46 . I $T(@XMCMD)'[";;" S XMSG="-ERR no such command" X XMSEN Q
47 . I XMCMDS(XMSTATE)'[(U_XMCMD_U)="" S XMSG="-ERR no such command in "_XMSTATE_" state" X XMSEN Q
48 . D @XMCMD
49 I ER,$G(XMCMD)'="QUIT" D QUIT
50 Q
51DELE ;;
52 N XMID
53 S XMID=$P(XMRG," ",2,999)
54 Q:'$$OKID(XMID)
55 N XMREC,XMZ,XMOCTS
56 S XMZ=+^TMP("XM",$J,"POP3",XMID),XMOCTS=$P(^(XMID),U,2)
57 S ^TMP("XM",$J,"POP3","D",XMID)=XMZ
58 S XMREC=^TMP("XM",$J,"POP3")
59 S ^TMP("XM",$J,"POP3")=($P(XMREC,U,1)-1)_U_($P(XMREC,U,2)-XMOCTS)
60 S XMSG="+OK message "_XMID_" deleted" X XMSEN
61 Q
62OKID(XMID) ;
63 I XMID="" S XMSG="-ERR message-id required" X XMSEN Q 0
64 I +XMID'=XMID S XMSG="-ERR improper message-id" X XMSEN Q 0
65 I '$D(^TMP("XM",$J,"POP3",XMID)) S XMSG="-ERR no such message" X XMSEN Q 0
66 I $D(^TMP("XM",$J,"POP3","D",XMID)) S XMSG="-ERR message "_XMID_" already deleted" X XMSEN Q 0
67 Q 1
68LIST ;;
69 N XMID,XMOCTS
70 S XMID=$P(XMRG," ",2,999)
71 I XMID="" D Q
72 . S XMSG="+OK "_$P(^TMP("XM",$J,"POP3"),U,1)_" messages ("_$P(^("POP3"),U,2)_" octets)" X XMSEN Q:ER
73 . F S XMID=$O(^TMP("XM",$J,"POP3",XMID)) Q:'XMID S XMOCTS=$P(^(XMID),U,2) D Q:ER
74 . . Q:$D(^TMP("XM",$J,"POP3","D",XMID))
75 . . S XMSG=XMID_" "_XMOCTS X XMSEN
76 . S XMSG="." X XMSEN
77 Q:'$$OKID(XMID)
78 S XMSG="+OK "_XMID_" "_$P(^TMP("XM",$J,"POP3",XMID),U,2) X XMSEN
79 Q
80NOOP ;;
81 S XMSG="+OK" X XMSEN
82 Q
83PASS ;;
84 I '$D(XMACCESS) D LOGINERR("-ERR sorry, USER access code expected") Q
85 S XMVERIFY=$P(XMRG," ",2,999)
86 I XMVERIFY'="" D LOGIN Q
87 D LOGINERR("-ERR sorry, PASS verify code expected")
88 Q
89LOGIN ;
90 N XMLOGIN
91 S XMLOGIN=$$LOGINOK
92 I 'XMLOGIN D LOGINERR("-ERR "_$P(XMLOGIN,U,2)) Q
93 K XMACCESS,XMVERIFY
94 S XMSTATE="TRAN"
95 S XMDUZ=DUZ
96 D INIT^XMVVITAE
97 D MAILDROP
98 D RSET
99 Q
100LOGINOK() ;
101 I $T(@"USERSET^XUSRA")="" Q $$OLDCHK
102 Q $$USERSET^XUSRA(XMACCESS_";"_XMVERIFY)
103OLDCHK() ;
104 N XUSER,XUF,%1,XMLOGIN
105 S XUF=0
106 S XMLOGIN=$$CHECKAV^XUS(XMACCESS_";"_XMVERIFY)
107 I XMLOGIN S DUZ=XMLOGIN Q 1
108 Q "0^Not a valid ACCESS CODE/VERIFY CODE pair"
109MAILDROP ;
110 N XMKZ,XMZ,XMOCTS,XMID
111 K ^TMP("XM",$J,"POP3")
112 S (XMID,XMKZ,XMTOCTS)=0
113 F S XMKZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ)) Q:'XMKZ D
114 . S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,0))
115 . I '$D(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)) D ADDITC^XMUT4A(XMDUZ,XMK,XMZ,XMKZ)
116 . I '$D(^XMB(3.9,XMZ,0)) D ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ) Q
117 . S XMID=XMID+1
118 . S XMOCTS=$$OCTETS(XMZ)
119 . S XMTOCTS=XMTOCTS+XMOCTS
120 . S ^TMP("XM",$J,"POP3",XMID)=XMZ_U_XMOCTS
121 S XMTMSGS=XMID
122 Q
123OCTETS(XMZ) ; Returns the number of 'octets' in a message.
124 ; Basically, that's a count of the number of characters.
125 ; We estimate it by multiplying the number of lines by 50.
126 Q $P($G(^XMB(3.9,XMZ,2,0)),U,4)*50
127LOGINERR(XMSG) ;
128 K XMACCESS,XMVERIFY
129 S XMTRY=$G(XMTRY)+1
130 I XMTRY<3 X XMSEN Q
131 D SIGNOFF(XMSG_"; 3 tries and you're out!")
132 S XMCMD="QUIT"
133 Q
134QUIT ;;
135 I XMSTATE="TRAN",'ER D UPDATE
136 K ^TMP("XM",$J,"POP3")
137 D SIGNOFF("")
138 Q
139SIGNOFF(XMSG) ;
140 S XMSG=$S(XMSG'="":XMSG_"; ",ER:"-ERR ",1:"+OK ")_^XMB("NETNAME")_" POP3 server signing off" X XMSEN
141 Q
142RETR ;;
143 N XMID
144 S XMID=$P(XMRG," ",2,999)
145 Q:'$$OKID(XMID)
146 S XMSG="+OK "_$P(^TMP("XM",$J,"POP3",XMID),U,2)_" octets" X XMSEN Q:ER
147 D RETRIEVE(XMID,"*")
148 Q
149RSET ;;
150 K ^TMP("XM",$J,"POP3","D")
151 S ^TMP("XM",$J,"POP3")=XMTMSGS_U_XMTOCTS
152 S XMSG="+OK maildrop has "_XMTMSGS_" messages ("_XMTOCTS_" octets)" X XMSEN
153 Q
154STAT ;;
155 S XMSG="+OK "_$P(^TMP("XM",$J,"POP3"),U,1)_" "_$P(^("POP3"),U,2) X XMSEN
156 Q
157TOP ;;
158 N XMID,XMLINES
159 S XMID=$P(XMRG," ",2)
160 Q:'$$OKID(XMID)
161 S XMLINES=$P(XMRG," ",3,999)
162 I +XMLINES'=XMLINES S XMSG="-ERR improper number of lines" X XMSEN Q
163 S XMSG="+OK" X XMSEN Q:ER
164 D RETRIEVE(XMID,XMLINES)
165 Q
166UIDL ;;
167 N XMID,XMZ
168 S XMID=$P(XMRG," ",2,999)
169 I XMID="" D Q
170 . S XMSG="+OK" X XMSEN Q:ER
171 . F S XMID=$O(^TMP("XM",$J,"POP3",XMID)) Q:'XMID S XMZ=+^(XMID) D Q:ER
172 . . Q:$D(^TMP("XM",$J,"POP3","D",XMID))
173 . . S XMSG=XMID_" "_XMZ X XMSEN
174 . S XMSG="." X XMSEN
175 Q:'$$OKID(XMID)
176 S XMSG="+OK "_XMID_" "_+^TMP("XM",$J,"POP3",XMID) X XMSEN
177 Q
178USER ;;
179 S XMACCESS=$P(XMRG," ",2,999)
180 I XMACCESS'="" S XMSG="+OK" X XMSEN Q
181 D LOGINERR("-ERR sorry, USER access code expected")
182 Q
183UPDATE ;
184 N XMID,XMZ
185 S XMID=0
186 F S XMID=$O(^TMP("XM",$J,"POP3","D",XMID)) Q:'XMID S XMZ=+^(XMID) D DEL^XMXMSGS2(XMDUZ,"",XMZ)
187 Q
188RETRIEVE(XMID,XMLINES) ;
189 N XMZ,XMRESP,XMIM,XMINSTR,XMIU
190 S XMZ=+^TMP("XM",$J,"POP3",XMID)
191 D INMSG^XMXUTIL2(XMDUZ,"",XMZ,"","I",.XMIM,.XMINSTR,.XMIU)
192 D RETRXMZ(XMZ,XMLINES,.XMIM) Q:ER
193 I 'XMLINES,XMIM("RESPS") D Q:ER
194 . F XMRESP=XMIU("RESP")+1:1:XMIM("RESPS") D Q:ER
195 . . N XMIR
196 . . D INRESP^XMXUTIL2(XMZ,XMRESP,"I",.XMIR) Q:'$D(XMIR)
197 . . I XMIR("SUBJ")?1"R".N S XMIR("SUBJ")="Re: "_XMIM("SUBJ")
198 . . S XMSG="" X XMSEN Q:ER ; just for visual separation
199 . . D RETRXMZ(XMIR("XMZ"),"*",.XMIR,XMZ) Q:ER
200 E S XMRESP=0
201 S XMSG="." X XMSEN Q:ER
202 D LASTACC^XMXUTIL(XMDUZ,XMK,XMZ,XMRESP,.XMIM,.XMINSTR,.XMIU)
203 I $D(^XMB(3.7,XMDUZ,"N0",XMK,XMZ)),+XMRESP=+$P($G(^XMB(3.9,XMZ,3,0)),U,4) D NONEW^XMXUTIL(XMDUZ,XMK,XMZ,1)
204 Q
205RETRXMZ(XMZ,XMLINES,XMIM,XMZO) ;
206 N XMI
207 I $O(^XMB(3.9,XMZ,2,0))'<1 D CRE8HDR(XMZ,.XMIM,.XMZO) Q:ER
208 S XMI=0
209 F S XMI=$O(^XMB(3.9,XMZ,2,XMI)) Q:'XMI S XMSG=^(XMI,0) S:$E(XMSG)="." XMSG="."_XMSG X XMSEN Q:ER I XMLINES,XMI'<XMLINES Q
210 Q
211CRE8HDR(XMZ,XMIM,XMZO) ;
212 S XMSG="Message-ID: <"_XMZ_"@"_^XMB("NETNAME")_">" X XMSEN Q:ER
213 S XMSG="From: <"_$$NETNAME^XMXUTIL(XMIM("FROM"))_">" X XMSEN Q:ER
214 S XMSG="To: <"_XMV("NETNAME")_">" X XMSEN Q:ER
215 S XMSG="Subject: "_XMIM("SUBJ") X XMSEN Q:ER
216 S XMSG="Date: "_$$INDT^XMXUTIL1(XMIM("DATE")) X XMSEN Q:ER
217 S XMSG="" X XMSEN Q:ER
218 Q
Note: See TracBrowser for help on using the repository browser.