XMRPOP ;ISC-SF/GMB-POP3 Server (RFC 1939) ;05/20/2002 07:05
;;8.0;MailMan;;Jun 28, 2002
; Replaces the class III routines ^XMRPOPA, ^XMRPOPB, ^XMRPOPC,
; which were written by Chiao-Ming Wu, WASH-ISC.
;
; Implements RFC 1939 (replaces RFC 1725)
; Post Office Protocol - Version 3 (POP3) maildrop service
;
; Rather than locking the user's IN basket, which severely disrupts
; mail delivery, we take a snapshot of it, and keep the snapshot in
; a temp global. We then use the temp global during the session.
; Here is the layout of the global:
;
; ^TMP("XM",$J,"POP3")=# msgs^# octets ; total msgs in IN basket
; ; (updated if msgs are deleted)
; ^TMP("XM",$J,"POP3",1)=XMZ^# octets ; msgs 1 thru n are in
; ... ; IN basket.
; ^TMP("XM",$J,"POP3",i)=XMZ^# octets ;
; ^TMP("XM",$J,"POP3",j)=XMZ^# octets ;
; ... ;
; ^TMP("XM",$J,"POP3",n)=XMZ^# octets ;
; ;
; ^TMP("XM",$J,"POP3","D",i)=XMZ ; user deleted msg i
; ^TMP("XM",$J,"POP3","D",j)=XMZ ; user deleted msg j
ENTRY ;
N XMK,XMSTATE,XMCMDS,XMCMD,XMDUZ,XMACCESS,XMVERIFY,XMTRY,XMTMSGS,XMTOCTS,XMV
I '$D(ZTQUEUED) S X=$S($D(^%ZOSF("ERRTN")):^("ERRTN"),1:"ERR^ZU"),@(^%ZOSF("TRAP"))
I '$G(DUZ) S DUZ=.5
I '$D(XMDUZ) S XMDUZ=DUZ
I '$D(XMC("BATCH")) S XMC("BATCH")=0
I $S('$D(XMCHAN):1,XMCHAN="":1,1:0) S XMCHAN="TCP/IP-MAILMAN"
D OPEN^XML
I $G(ER)=1 D ^%ZISC:IO'=$G(IO(0)) W !,"Device open failed !",$C(7) Q
S:'$D(XM) XM=""
I 'XMC("BATCH") X ^%ZOSF("EOFF") S X=255 X ^%ZOSF("RM"),^%ZOSF("TYPE-AHEAD")
S ER=0
S XMK=1
S XMSG="+OK "_^XMB("NETNAME")_" POP3 server ready (Comments to: POSTMASTER@"_^XMB("NETNAME")_")" X XMSEN Q:ER
S XMCMDS("AUTH")="^PASS^QUIT^USER^"
S XMCMDS("TRAN")="^DELE^LIST^NOOP^QUIT^RETR^RSET^STAT^TOP^UIDL^"
S XMSTATE="AUTH"
F X XMREC Q:ER D Q:XMCMD="QUIT"!ER
. I XMRG="" S ER=1,XMCMD="" Q
. S XMCMD=$P(XMRG," ",1)
. I $L(XMCMD)<3!($L(XMCMD)>4)!(XMCMD'?.U) S XMSG="-ERR no such command" X XMSEN Q
. I $T(@XMCMD)'[";;" S XMSG="-ERR no such command" X XMSEN Q
. I XMCMDS(XMSTATE)'[(U_XMCMD_U)="" S XMSG="-ERR no such command in "_XMSTATE_" state" X XMSEN Q
. D @XMCMD
I ER,$G(XMCMD)'="QUIT" D QUIT
Q
DELE ;;
N XMID
S XMID=$P(XMRG," ",2,999)
Q:'$$OKID(XMID)
N XMREC,XMZ,XMOCTS
S XMZ=+^TMP("XM",$J,"POP3",XMID),XMOCTS=$P(^(XMID),U,2)
S ^TMP("XM",$J,"POP3","D",XMID)=XMZ
S XMREC=^TMP("XM",$J,"POP3")
S ^TMP("XM",$J,"POP3")=($P(XMREC,U,1)-1)_U_($P(XMREC,U,2)-XMOCTS)
S XMSG="+OK message "_XMID_" deleted" X XMSEN
Q
OKID(XMID) ;
I XMID="" S XMSG="-ERR message-id required" X XMSEN Q 0
I +XMID'=XMID S XMSG="-ERR improper message-id" X XMSEN Q 0
I '$D(^TMP("XM",$J,"POP3",XMID)) S XMSG="-ERR no such message" X XMSEN Q 0
I $D(^TMP("XM",$J,"POP3","D",XMID)) S XMSG="-ERR message "_XMID_" already deleted" X XMSEN Q 0
Q 1
LIST ;;
N XMID,XMOCTS
S XMID=$P(XMRG," ",2,999)
I XMID="" D Q
. S XMSG="+OK "_$P(^TMP("XM",$J,"POP3"),U,1)_" messages ("_$P(^("POP3"),U,2)_" octets)" X XMSEN Q:ER
. F S XMID=$O(^TMP("XM",$J,"POP3",XMID)) Q:'XMID S XMOCTS=$P(^(XMID),U,2) D Q:ER
. . Q:$D(^TMP("XM",$J,"POP3","D",XMID))
. . S XMSG=XMID_" "_XMOCTS X XMSEN
. S XMSG="." X XMSEN
Q:'$$OKID(XMID)
S XMSG="+OK "_XMID_" "_$P(^TMP("XM",$J,"POP3",XMID),U,2) X XMSEN
Q
NOOP ;;
S XMSG="+OK" X XMSEN
Q
PASS ;;
I '$D(XMACCESS) D LOGINERR("-ERR sorry, USER access code expected") Q
S XMVERIFY=$P(XMRG," ",2,999)
I XMVERIFY'="" D LOGIN Q
D LOGINERR("-ERR sorry, PASS verify code expected")
Q
LOGIN ;
N XMLOGIN
S XMLOGIN=$$LOGINOK
I 'XMLOGIN D LOGINERR("-ERR "_$P(XMLOGIN,U,2)) Q
K XMACCESS,XMVERIFY
S XMSTATE="TRAN"
S XMDUZ=DUZ
D INIT^XMVVITAE
D MAILDROP
D RSET
Q
LOGINOK() ;
I $T(@"USERSET^XUSRA")="" Q $$OLDCHK
Q $$USERSET^XUSRA(XMACCESS_";"_XMVERIFY)
OLDCHK() ;
N XUSER,XUF,%1,XMLOGIN
S XUF=0
S XMLOGIN=$$CHECKAV^XUS(XMACCESS_";"_XMVERIFY)
I XMLOGIN S DUZ=XMLOGIN Q 1
Q "0^Not a valid ACCESS CODE/VERIFY CODE pair"
MAILDROP ;
N XMKZ,XMZ,XMOCTS,XMID
K ^TMP("XM",$J,"POP3")
S (XMID,XMKZ,XMTOCTS)=0
F S XMKZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ)) Q:'XMKZ D
. S XMZ=$O(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,0))
. I '$D(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0)) D ADDITC^XMUT4A(XMDUZ,XMK,XMZ,XMKZ)
. I '$D(^XMB(3.9,XMZ,0)) D ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ) Q
. S XMID=XMID+1
. S XMOCTS=$$OCTETS(XMZ)
. S XMTOCTS=XMTOCTS+XMOCTS
. S ^TMP("XM",$J,"POP3",XMID)=XMZ_U_XMOCTS
S XMTMSGS=XMID
Q
OCTETS(XMZ) ; Returns the number of 'octets' in a message.
; Basically, that's a count of the number of characters.
; We estimate it by multiplying the number of lines by 50.
Q $P($G(^XMB(3.9,XMZ,2,0)),U,4)*50
LOGINERR(XMSG) ;
K XMACCESS,XMVERIFY
S XMTRY=$G(XMTRY)+1
I XMTRY<3 X XMSEN Q
D SIGNOFF(XMSG_"; 3 tries and you're out!")
S XMCMD="QUIT"
Q
QUIT ;;
I XMSTATE="TRAN",'ER D UPDATE
K ^TMP("XM",$J,"POP3")
D SIGNOFF("")
Q
SIGNOFF(XMSG) ;
S XMSG=$S(XMSG'="":XMSG_"; ",ER:"-ERR ",1:"+OK ")_^XMB("NETNAME")_" POP3 server signing off" X XMSEN
Q
RETR ;;
N XMID
S XMID=$P(XMRG," ",2,999)
Q:'$$OKID(XMID)
S XMSG="+OK "_$P(^TMP("XM",$J,"POP3",XMID),U,2)_" octets" X XMSEN Q:ER
D RETRIEVE(XMID,"*")
Q
RSET ;;
K ^TMP("XM",$J,"POP3","D")
S ^TMP("XM",$J,"POP3")=XMTMSGS_U_XMTOCTS
S XMSG="+OK maildrop has "_XMTMSGS_" messages ("_XMTOCTS_" octets)" X XMSEN
Q
STAT ;;
S XMSG="+OK "_$P(^TMP("XM",$J,"POP3"),U,1)_" "_$P(^("POP3"),U,2) X XMSEN
Q
TOP ;;
N XMID,XMLINES
S XMID=$P(XMRG," ",2)
Q:'$$OKID(XMID)
S XMLINES=$P(XMRG," ",3,999)
I +XMLINES'=XMLINES S XMSG="-ERR improper number of lines" X XMSEN Q
S XMSG="+OK" X XMSEN Q:ER
D RETRIEVE(XMID,XMLINES)
Q
UIDL ;;
N XMID,XMZ
S XMID=$P(XMRG," ",2,999)
I XMID="" D Q
. S XMSG="+OK" X XMSEN Q:ER
. F S XMID=$O(^TMP("XM",$J,"POP3",XMID)) Q:'XMID S XMZ=+^(XMID) D Q:ER
. . Q:$D(^TMP("XM",$J,"POP3","D",XMID))
. . S XMSG=XMID_" "_XMZ X XMSEN
. S XMSG="." X XMSEN
Q:'$$OKID(XMID)
S XMSG="+OK "_XMID_" "_+^TMP("XM",$J,"POP3",XMID) X XMSEN
Q
USER ;;
S XMACCESS=$P(XMRG," ",2,999)
I XMACCESS'="" S XMSG="+OK" X XMSEN Q
D LOGINERR("-ERR sorry, USER access code expected")
Q
UPDATE ;
N XMID,XMZ
S XMID=0
F S XMID=$O(^TMP("XM",$J,"POP3","D",XMID)) Q:'XMID S XMZ=+^(XMID) D DEL^XMXMSGS2(XMDUZ,"",XMZ)
Q
RETRIEVE(XMID,XMLINES) ;
N XMZ,XMRESP,XMIM,XMINSTR,XMIU
S XMZ=+^TMP("XM",$J,"POP3",XMID)
D INMSG^XMXUTIL2(XMDUZ,"",XMZ,"","I",.XMIM,.XMINSTR,.XMIU)
D RETRXMZ(XMZ,XMLINES,.XMIM) Q:ER
I 'XMLINES,XMIM("RESPS") D Q:ER
. F XMRESP=XMIU("RESP")+1:1:XMIM("RESPS") D Q:ER
. . N XMIR
. . D INRESP^XMXUTIL2(XMZ,XMRESP,"I",.XMIR) Q:'$D(XMIR)
. . I XMIR("SUBJ")?1"R".N S XMIR("SUBJ")="Re: "_XMIM("SUBJ")
. . S XMSG="" X XMSEN Q:ER ; just for visual separation
. . D RETRXMZ(XMIR("XMZ"),"*",.XMIR,XMZ) Q:ER
E S XMRESP=0
S XMSG="." X XMSEN Q:ER
D LASTACC^XMXUTIL(XMDUZ,XMK,XMZ,XMRESP,.XMIM,.XMINSTR,.XMIU)
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)
Q
RETRXMZ(XMZ,XMLINES,XMIM,XMZO) ;
N XMI
I $O(^XMB(3.9,XMZ,2,0))'<1 D CRE8HDR(XMZ,.XMIM,.XMZO) Q:ER
S XMI=0
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
Q
CRE8HDR(XMZ,XMIM,XMZO) ;
S XMSG="Message-ID: <"_XMZ_"@"_^XMB("NETNAME")_">" X XMSEN Q:ER
S XMSG="From: <"_$$NETNAME^XMXUTIL(XMIM("FROM"))_">" X XMSEN Q:ER
S XMSG="To: <"_XMV("NETNAME")_">" X XMSEN Q:ER
S XMSG="Subject: "_XMIM("SUBJ") X XMSEN Q:ER
S XMSG="Date: "_$$INDT^XMXUTIL1(XMIM("DATE")) X XMSEN Q:ER
S XMSG="" X XMSEN Q:ER
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXMRPOP 7797 printed Sep 23, 2025@19:49:06 Page 2
XMRPOP ;ISC-SF/GMB-POP3 Server (RFC 1939) ;05/20/2002 07:05
+1 ;;8.0;MailMan;;Jun 28, 2002
+2 ; Replaces the class III routines ^XMRPOPA, ^XMRPOPB, ^XMRPOPC,
+3 ; which were written by Chiao-Ming Wu, WASH-ISC.
+4 ;
+5 ; Implements RFC 1939 (replaces RFC 1725)
+6 ; Post Office Protocol - Version 3 (POP3) maildrop service
+7 ;
+8 ; Rather than locking the user's IN basket, which severely disrupts
+9 ; mail delivery, we take a snapshot of it, and keep the snapshot in
+10 ; a temp global. We then use the temp global during the session.
+11 ; Here is the layout of the global:
+12 ;
+13 ; ^TMP("XM",$J,"POP3")=# msgs^# octets ; total msgs in IN basket
+14 ; ; (updated if msgs are deleted)
+15 ; ^TMP("XM",$J,"POP3",1)=XMZ^# octets ; msgs 1 thru n are in
+16 ; ... ; IN basket.
+17 ; ^TMP("XM",$J,"POP3",i)=XMZ^# octets ;
+18 ; ^TMP("XM",$J,"POP3",j)=XMZ^# octets ;
+19 ; ... ;
+20 ; ^TMP("XM",$J,"POP3",n)=XMZ^# octets ;
+21 ; ;
+22 ; ^TMP("XM",$J,"POP3","D",i)=XMZ ; user deleted msg i
+23 ; ^TMP("XM",$J,"POP3","D",j)=XMZ ; user deleted msg j
ENTRY ;
+1 NEW XMK,XMSTATE,XMCMDS,XMCMD,XMDUZ,XMACCESS,XMVERIFY,XMTRY,XMTMSGS,XMTOCTS,XMV
+2 IF '$DATA(ZTQUEUED)
SET X=$SELECT($DATA(^%ZOSF("ERRTN")):^("ERRTN"),1:"ERR^ZU")
SET @(^%ZOSF("TRAP"))
+3 IF '$GET(DUZ)
SET DUZ=.5
+4 IF '$DATA(XMDUZ)
SET XMDUZ=DUZ
+5 IF '$DATA(XMC("BATCH"))
SET XMC("BATCH")=0
+6 IF $SELECT('$DATA(XMCHAN):1,XMCHAN="":1,1:0)
SET XMCHAN="TCP/IP-MAILMAN"
+7 DO OPEN^XML
+8 IF $GET(ER)=1
if IO'=$GET(IO(0))
DO ^%ZISC
WRITE !,"Device open failed !",$CHAR(7)
QUIT
+9 if '$DATA(XM)
SET XM=""
+10 IF 'XMC("BATCH")
XECUTE ^%ZOSF("EOFF")
SET X=255
XECUTE ^%ZOSF("RM")
XECUTE ^%ZOSF("TYPE-AHEAD")
+11 SET ER=0
+12 SET XMK=1
+13 SET XMSG="+OK "_^XMB("NETNAME")_" POP3 server ready (Comments to: POSTMASTER@"_^XMB("NETNAME")_")"
XECUTE XMSEN
if ER
QUIT
+14 SET XMCMDS("AUTH")="^PASS^QUIT^USER^"
+15 SET XMCMDS("TRAN")="^DELE^LIST^NOOP^QUIT^RETR^RSET^STAT^TOP^UIDL^"
+16 SET XMSTATE="AUTH"
+17 FOR
XECUTE XMREC
if ER
QUIT
Begin DoDot:1
+18 IF XMRG=""
SET ER=1
SET XMCMD=""
QUIT
+19 SET XMCMD=$PIECE(XMRG," ",1)
+20 IF $LENGTH(XMCMD)<3!($LENGTH(XMCMD)>4)!(XMCMD'?.U)
SET XMSG="-ERR no such command"
XECUTE XMSEN
QUIT
+21 IF $TEXT(@XMCMD)'[";;"
SET XMSG="-ERR no such command"
XECUTE XMSEN
QUIT
+22 IF XMCMDS(XMSTATE)'[(U_XMCMD_U)=""
SET XMSG="-ERR no such command in "_XMSTATE_" state"
XECUTE XMSEN
QUIT
+23 DO @XMCMD
End DoDot:1
if XMCMD="QUIT"!ER
QUIT
+24 IF ER
IF $GET(XMCMD)'="QUIT"
DO QUIT
+25 QUIT
DELE ;;
+1 NEW XMID
+2 SET XMID=$PIECE(XMRG," ",2,999)
+3 if '$$OKID(XMID)
QUIT
+4 NEW XMREC,XMZ,XMOCTS
+5 SET XMZ=+^TMP("XM",$JOB,"POP3",XMID)
SET XMOCTS=$PIECE(^(XMID),U,2)
+6 SET ^TMP("XM",$JOB,"POP3","D",XMID)=XMZ
+7 SET XMREC=^TMP("XM",$JOB,"POP3")
+8 SET ^TMP("XM",$JOB,"POP3")=($PIECE(XMREC,U,1)-1)_U_($PIECE(XMREC,U,2)-XMOCTS)
+9 SET XMSG="+OK message "_XMID_" deleted"
XECUTE XMSEN
+10 QUIT
OKID(XMID) ;
+1 IF XMID=""
SET XMSG="-ERR message-id required"
XECUTE XMSEN
QUIT 0
+2 IF +XMID'=XMID
SET XMSG="-ERR improper message-id"
XECUTE XMSEN
QUIT 0
+3 IF '$DATA(^TMP("XM",$JOB,"POP3",XMID))
SET XMSG="-ERR no such message"
XECUTE XMSEN
QUIT 0
+4 IF $DATA(^TMP("XM",$JOB,"POP3","D",XMID))
SET XMSG="-ERR message "_XMID_" already deleted"
XECUTE XMSEN
QUIT 0
+5 QUIT 1
LIST ;;
+1 NEW XMID,XMOCTS
+2 SET XMID=$PIECE(XMRG," ",2,999)
+3 IF XMID=""
Begin DoDot:1
+4 SET XMSG="+OK "_$PIECE(^TMP("XM",$JOB,"POP3"),U,1)_" messages ("_$PIECE(^("POP3"),U,2)_" octets)"
XECUTE XMSEN
if ER
QUIT
+5 FOR
SET XMID=$ORDER(^TMP("XM",$JOB,"POP3",XMID))
if 'XMID
QUIT
SET XMOCTS=$PIECE(^(XMID),U,2)
Begin DoDot:2
+6 if $DATA(^TMP("XM",$JOB,"POP3","D",XMID))
QUIT
+7 SET XMSG=XMID_" "_XMOCTS
XECUTE XMSEN
End DoDot:2
if ER
QUIT
+8 SET XMSG="."
XECUTE XMSEN
End DoDot:1
QUIT
+9 if '$$OKID(XMID)
QUIT
+10 SET XMSG="+OK "_XMID_" "_$PIECE(^TMP("XM",$JOB,"POP3",XMID),U,2)
XECUTE XMSEN
+11 QUIT
NOOP ;;
+1 SET XMSG="+OK"
XECUTE XMSEN
+2 QUIT
PASS ;;
+1 IF '$DATA(XMACCESS)
DO LOGINERR("-ERR sorry, USER access code expected")
QUIT
+2 SET XMVERIFY=$PIECE(XMRG," ",2,999)
+3 IF XMVERIFY'=""
DO LOGIN
QUIT
+4 DO LOGINERR("-ERR sorry, PASS verify code expected")
+5 QUIT
LOGIN ;
+1 NEW XMLOGIN
+2 SET XMLOGIN=$$LOGINOK
+3 IF 'XMLOGIN
DO LOGINERR("-ERR "_$PIECE(XMLOGIN,U,2))
QUIT
+4 KILL XMACCESS,XMVERIFY
+5 SET XMSTATE="TRAN"
+6 SET XMDUZ=DUZ
+7 DO INIT^XMVVITAE
+8 DO MAILDROP
+9 DO RSET
+10 QUIT
LOGINOK() ;
+1 IF $TEXT(@"USERSET^XUSRA")=""
QUIT $$OLDCHK
+2 QUIT $$USERSET^XUSRA(XMACCESS_";"_XMVERIFY)
OLDCHK() ;
+1 NEW XUSER,XUF,%1,XMLOGIN
+2 SET XUF=0
+3 SET XMLOGIN=$$CHECKAV^XUS(XMACCESS_";"_XMVERIFY)
+4 IF XMLOGIN
SET DUZ=XMLOGIN
QUIT 1
+5 QUIT "0^Not a valid ACCESS CODE/VERIFY CODE pair"
MAILDROP ;
+1 NEW XMKZ,XMZ,XMOCTS,XMID
+2 KILL ^TMP("XM",$JOB,"POP3")
+3 SET (XMID,XMKZ,XMTOCTS)=0
+4 FOR
SET XMKZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ))
if 'XMKZ
QUIT
Begin DoDot:1
+5 SET XMZ=$ORDER(^XMB(3.7,XMDUZ,2,XMK,1,"C",XMKZ,0))
+6 IF '$DATA(^XMB(3.7,XMDUZ,2,XMK,1,XMZ,0))
DO ADDITC^XMUT4A(XMDUZ,XMK,XMZ,XMKZ)
+7 IF '$DATA(^XMB(3.9,XMZ,0))
DO ZAPIT^XMXMSGS2(XMDUZ,XMK,XMZ)
QUIT
+8 SET XMID=XMID+1
+9 SET XMOCTS=$$OCTETS(XMZ)
+10 SET XMTOCTS=XMTOCTS+XMOCTS
+11 SET ^TMP("XM",$JOB,"POP3",XMID)=XMZ_U_XMOCTS
End DoDot:1
+12 SET XMTMSGS=XMID
+13 QUIT
OCTETS(XMZ) ; Returns the number of 'octets' in a message.
+1 ; Basically, that's a count of the number of characters.
+2 ; We estimate it by multiplying the number of lines by 50.
+3 QUIT $PIECE($GET(^XMB(3.9,XMZ,2,0)),U,4)*50
LOGINERR(XMSG) ;
+1 KILL XMACCESS,XMVERIFY
+2 SET XMTRY=$GET(XMTRY)+1
+3 IF XMTRY<3
XECUTE XMSEN
QUIT
+4 DO SIGNOFF(XMSG_"; 3 tries and you're out!")
+5 SET XMCMD="QUIT"
+6 QUIT
QUIT ;;
+1 IF XMSTATE="TRAN"
IF 'ER
DO UPDATE
+2 KILL ^TMP("XM",$JOB,"POP3")
+3 DO SIGNOFF("")
+4 QUIT
SIGNOFF(XMSG) ;
+1 SET XMSG=$SELECT(XMSG'="":XMSG_"; ",ER:"-ERR ",1:"+OK ")_^XMB("NETNAME")_" POP3 server signing off"
XECUTE XMSEN
+2 QUIT
RETR ;;
+1 NEW XMID
+2 SET XMID=$PIECE(XMRG," ",2,999)
+3 if '$$OKID(XMID)
QUIT
+4 SET XMSG="+OK "_$PIECE(^TMP("XM",$JOB,"POP3",XMID),U,2)_" octets"
XECUTE XMSEN
if ER
QUIT
+5 DO RETRIEVE(XMID,"*")
+6 QUIT
RSET ;;
+1 KILL ^TMP("XM",$JOB,"POP3","D")
+2 SET ^TMP("XM",$JOB,"POP3")=XMTMSGS_U_XMTOCTS
+3 SET XMSG="+OK maildrop has "_XMTMSGS_" messages ("_XMTOCTS_" octets)"
XECUTE XMSEN
+4 QUIT
STAT ;;
+1 SET XMSG="+OK "_$PIECE(^TMP("XM",$JOB,"POP3"),U,1)_" "_$PIECE(^("POP3"),U,2)
XECUTE XMSEN
+2 QUIT
TOP ;;
+1 NEW XMID,XMLINES
+2 SET XMID=$PIECE(XMRG," ",2)
+3 if '$$OKID(XMID)
QUIT
+4 SET XMLINES=$PIECE(XMRG," ",3,999)
+5 IF +XMLINES'=XMLINES
SET XMSG="-ERR improper number of lines"
XECUTE XMSEN
QUIT
+6 SET XMSG="+OK"
XECUTE XMSEN
if ER
QUIT
+7 DO RETRIEVE(XMID,XMLINES)
+8 QUIT
UIDL ;;
+1 NEW XMID,XMZ
+2 SET XMID=$PIECE(XMRG," ",2,999)
+3 IF XMID=""
Begin DoDot:1
+4 SET XMSG="+OK"
XECUTE XMSEN
if ER
QUIT
+5 FOR
SET XMID=$ORDER(^TMP("XM",$JOB,"POP3",XMID))
if 'XMID
QUIT
SET XMZ=+^(XMID)
Begin DoDot:2
+6 if $DATA(^TMP("XM",$JOB,"POP3","D",XMID))
QUIT
+7 SET XMSG=XMID_" "_XMZ
XECUTE XMSEN
End DoDot:2
if ER
QUIT
+8 SET XMSG="."
XECUTE XMSEN
End DoDot:1
QUIT
+9 if '$$OKID(XMID)
QUIT
+10 SET XMSG="+OK "_XMID_" "_+^TMP("XM",$JOB,"POP3",XMID)
XECUTE XMSEN
+11 QUIT
USER ;;
+1 SET XMACCESS=$PIECE(XMRG," ",2,999)
+2 IF XMACCESS'=""
SET XMSG="+OK"
XECUTE XMSEN
QUIT
+3 DO LOGINERR("-ERR sorry, USER access code expected")
+4 QUIT
UPDATE ;
+1 NEW XMID,XMZ
+2 SET XMID=0
+3 FOR
SET XMID=$ORDER(^TMP("XM",$JOB,"POP3","D",XMID))
if 'XMID
QUIT
SET XMZ=+^(XMID)
DO DEL^XMXMSGS2(XMDUZ,"",XMZ)
+4 QUIT
RETRIEVE(XMID,XMLINES) ;
+1 NEW XMZ,XMRESP,XMIM,XMINSTR,XMIU
+2 SET XMZ=+^TMP("XM",$JOB,"POP3",XMID)
+3 DO INMSG^XMXUTIL2(XMDUZ,"",XMZ,"","I",.XMIM,.XMINSTR,.XMIU)
+4 DO RETRXMZ(XMZ,XMLINES,.XMIM)
if ER
QUIT
+5 IF 'XMLINES
IF XMIM("RESPS")
Begin DoDot:1
+6 FOR XMRESP=XMIU("RESP")+1:1:XMIM("RESPS")
Begin DoDot:2
+7 NEW XMIR
+8 DO INRESP^XMXUTIL2(XMZ,XMRESP,"I",.XMIR)
if '$DATA(XMIR)
QUIT
+9 IF XMIR("SUBJ")?1"R".N
SET XMIR("SUBJ")="Re: "_XMIM("SUBJ")
+10 ; just for visual separation
SET XMSG=""
XECUTE XMSEN
if ER
QUIT
+11 DO RETRXMZ(XMIR("XMZ"),"*",.XMIR,XMZ)
if ER
QUIT
End DoDot:2
if ER
QUIT
End DoDot:1
if ER
QUIT
+12 IF '$TEST
SET XMRESP=0
+13 SET XMSG="."
XECUTE XMSEN
if ER
QUIT
+14 DO LASTACC^XMXUTIL(XMDUZ,XMK,XMZ,XMRESP,.XMIM,.XMINSTR,.XMIU)
+15 IF $DATA(^XMB(3.7,XMDUZ,"N0",XMK,XMZ))
IF +XMRESP=+$PIECE($GET(^XMB(3.9,XMZ,3,0)),U,4)
DO NONEW^XMXUTIL(XMDUZ,XMK,XMZ,1)
+16 QUIT
RETRXMZ(XMZ,XMLINES,XMIM,XMZO) ;
+1 NEW XMI
+2 IF $ORDER(^XMB(3.9,XMZ,2,0))'<1
DO CRE8HDR(XMZ,.XMIM,.XMZO)
if ER
QUIT
+3 SET XMI=0
+4 FOR
SET XMI=$ORDER(^XMB(3.9,XMZ,2,XMI))
if 'XMI
QUIT
SET XMSG=^(XMI,0)
if $EXTRACT(XMSG)="."
SET XMSG="."_XMSG
XECUTE XMSEN
if ER
QUIT
IF XMLINES
IF XMI'<XMLINES
QUIT
+5 QUIT
CRE8HDR(XMZ,XMIM,XMZO) ;
+1 SET XMSG="Message-ID: <"_XMZ_"@"_^XMB("NETNAME")_">"
XECUTE XMSEN
if ER
QUIT
+2 SET XMSG="From: <"_$$NETNAME^XMXUTIL(XMIM("FROM"))_">"
XECUTE XMSEN
if ER
QUIT
+3 SET XMSG="To: <"_XMV("NETNAME")_">"
XECUTE XMSEN
if ER
QUIT
+4 SET XMSG="Subject: "_XMIM("SUBJ")
XECUTE XMSEN
if ER
QUIT
+5 SET XMSG="Date: "_$$INDT^XMXUTIL1(XMIM("DATE"))
XECUTE XMSEN
if ER
QUIT
+6 SET XMSG=""
XECUTE XMSEN
if ER
QUIT
+7 QUIT
