XMRPOP.m

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

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