C
C	This program demonstrates the use of the HPSS library from
C	FORTRAN.  It opens a specific mail file and serves the
C	individual messages as documents.  It's not particularly useful
C	as a script but was chosen as an example because of the high
C	overhead of openning a mail file.
C
C	The program takes as a command line argument the file specification
C	of the MAIL file to server followed optionally by a slash and
C	the name of the folder within that mail file (default MAIL), e.g.:
C
C	   mcr sys$disk:[]hpss_mail USER:[SMITH.MAIL]MAIL.MAI/REPORTS
C
C	The process running this program must have the same group logical
C	name table as the web server (i.e. same UIC group).
C
C	Author: David Jones
C	Date:	6-FEB-2000
C
	PROGRAM HPSS_MAIL
	IMPLICIT NONE
	INTEGER LIB$GET_FOREIGN, STATUS, MFLEN, ITEM_SET, CONTEXT, I
	INTEGER FOLDER_NDX, MCONTEXT, MCOUNT, FN_LEN
	INTEGER LIB$INIT_TIMER
	CHARACTER MFILE*252
	INTEGER IN_ITEM(200), OUT_ITEM(200)
	INTEGER MAIL$MAILFILE_OPEN, MAIL$MAILFILE_BEGIN
	INTEGER MAIL$MAILFILE_CLOSE, MAIL$MAILFILE_END
	INTEGER MAIL$MAILFILE_INFO_FILE, LIST_FOLDER
	INTEGER MAIL$MESSAGE_BEGIN, MAIL$MESSAGE_END
	EXTERNAL LIST_FOLDER
	INCLUDE '($MAILDEF)'
C
	CHARACTER*40 FOLDER_NAME
C
C	The command line argument is the name of the mail file and a
C	slash followed by the folder name.  Get the command line
C	and parse.
C
10	STATUS = LIB$GET_FOREIGN ( MFILE, 'Mail file: ', MFLEN )
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
	IF ( MFLEN .EQ. 0 ) GOTO 10
	FOLDER_NAME = 'MAIL'
	FN_LEN = 4			! default name
	DO I = MFLEN, 1, -1
	    IF ( MFILE(I:I) .EQ. '/' ) THEN
		CALL STR$UPCASE ( FOLDER_NAME, MFILE(I+1:) )
		FN_LEN = MFLEN - I
		MFLEN = I - 1
		GOTO 20
	    END IF
	END DO
20	CONTINUE
	IF ( MFLEN .EQ. 0 .OR. FN_LEN .EQ. 0 ) GOTO 10
C
C	Initialize mail file context and open mail file.
C
	CALL LIB$INIT_TIMER()
	CONTEXT = 0
	CALL ITEM_SET ( IN_ITEM, 1, 0, 0, 0, 0 )
	CALL ITEM_SET ( OUT_ITEM, 1, 0, 0, 0, 0 )
	STATUS = MAIL$MAILFILE_BEGIN ( CONTEXT, IN_ITEM, OUT_ITEM )
	IF ( .NOT. STATUS ) TYPE*,'Status of begin', STATUS
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
	CALL ITEM_SET ( IN_ITEM, 1, MFLEN, MAIL$_MAILFILE_NAME,
	1	%LOC(MFILE), 0 )
	STATUS = MAIL$MAILFILE_OPEN ( CONTEXT, IN_ITEM, OUT_ITEM )
	IF ( .NOT. STATUS ) TYPE*,'Status of file open ', STATUS
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
C	Initialize message context and invoke web server loop
C
	CALL ITEM_SET ( IN_ITEM, 1, 4, MAIL$_MESSAGE_FILE_CTX,
	1	%LOC(CONTEXT), 0 )
	CALL ITEM_SET ( OUT_ITEM, 1, 4, MAIL$_MESSAGE_SELECTED,
	1	%LOC(MCOUNT), 0 )
	STATUS = MAIL$MESSAGE_BEGIN ( MCONTEXT, IN_ITEM, OUT_ITEM )
	IF ( .NOT. STATUS ) 
	1	TYPE*,'Status of message select: ', STATUS, MCOUNT
	IF ( .NOT. STATUS ) CALL EXIT ( STATUS )
C
	CALL WEB_SERVER(MCONTEXT, FOLDER_NAME(:FN_LEN), MCOUNT)
C
C	Cleanup contexts and exit
C
	CALL ITEM_SET ( OUT_ITEM, 1, 0, 0, 0, 0 )
	CALL ITEM_SET ( IN_ITEM, 1, 0, 0, 0, 0 )
	STATUS = MAIL$MESSAGE_END ( MCONTEXT, IN_ITEM, OUT_ITEM )
C
	CALL ITEM_SET ( IN_ITEM, 1, 0, 0, 0, 0 )
	CALL ITEM_SET ( OUT_ITEM, 1, 0, 0, 0, 0 )
	STATUS = MAIL$MAILFILE_CLOSE ( CONTEXT, IN_ITEM, OUT_ITEM )
	STATUS = MAIL$MAILFILE_END ( CONTEXT, IN_ITEM, OUT_ITEM )
	CALL EXIT ( STATUS )
	END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C	Utility routines.
C
	SUBROUTINE ITEM_SET ( ITEM, NDX, LENGTH, CODE, BUFFER, RETLEN )
	IMPLICIT NONE
	INTEGER NDX, LENGTH, CODE, BUFFER, RETLEN
 	STRUCTURE /ITEM_LIST_ITEM/
	    INTEGER*2 LENGTH, CODE
	    INTEGER*4 BUFFER, RETLEN
	END STRUCTURE
	RECORD /ITEM_LIST_ITEM/ ITEM(500)
C
	ITEM(NDX).LENGTH = LENGTH
	ITEM(NDX).CODE = CODE
	ITEM(NDX).BUFFER = BUFFER
	ITEM(NDX).RETLEN = RETLEN
C
	ITEM(NDX+1).LENGTH = 0
	ITEM(NDX+1).CODE = 0
	END
C
	INTEGER FUNCTION STORE_TEXT ( TEXT, CC )
C
C	Save text in common block for later retrieval.
C
	IMPLICIT NONE
	INTEGER CTX, CC, OVER, I
	CHARACTER TEXT*(*)
C
	INTEGER HIGH_BLK, HIGH_OFF
	CHARACTER*16384 TBLK(256)		! 4 megabytes.
	COMMON /NDX_STORE/ HIGH_BLK, HIGH_OFF, TBLK
C
	IF ( HIGH_BLK .EQ. 0 ) THEN
	    HIGH_BLK = 1
	    HIGH_OFF = 0
	ELSE IF ( HIGH_BLK .GE. 256 ) THEN
	    STORE_TEXT = 0
	    RETURN
	END IF
	I = 0
	DO WHILE ( I .LT. LEN(TEXT) )
	    OVER = HIGH_OFF + LEN(TEXT) - I - LEN(TBLK(1))
	    IF ( OVER .GE. 0 ) THEN
C
C		String must be split.
C
		TBLK(HIGH_BLK)(HIGH_OFF+1:) = TEXT(I+1:LEN(TEXT)-OVER)
		I = I + LEN(TBLK(HIGH_BLK))-HIGH_OFF
		HIGH_BLK = HIGH_BLK + 1
		HIGH_OFF = 0
C
	    ELSE IF ( HIGH_BLK .GT. 256 ) THEN	! overflow
		STORE_TEXT = 0
		RETURN
	    ELSE
C
C		String fits in current block.
C
		TBLK(HIGH_BLK)(HIGH_OFF+1:HIGH_OFF+LEN(TEXT)-I) =
	1		TEXT(I+1:LEN(TEXT))
		HIGH_OFF = HIGH_OFF + LEN(TEXT) - I
		I = LEN(TEXT)
	    END IF
	END DO
C
	IF ( CC .NE. 0 ) THEN
	    IF ( HIGH_OFF .EQ. LEN(TBLK(HIGH_BLK)) ) THEN
		HIGH_BLK = HIGH_BLK + 1
		HIGH_OFF = 2
		TBLK(HIGH_BLK)(1:2) = CHAR(13)//CHAR(10)
	    ELSE IF ( (HIGH_OFF+1) .EQ. LEN(TBLK(HIGH_BLK)) ) THEN
		TBLK(HIGH_BLK)(HIGH_OFF+1:HIGH_OFF+1) = CHAR(13)
		HIGH_BLK = HIGH_BLK + 1
		HIGH_OFF = 1
		TBLK(HIGH_BLK)(1:1) = CHAR(10)
	    ELSE IF ( (HIGH_OFF+2) .EQ. LEN(TBLK(HIGH_BLK)) ) THEN
		TBLK(HIGH_BLK)(HIGH_OFF+1:HIGH_OFF+2) = CHAR(13)//CHAR(10)
		HIGH_OFF = 0
		HIGH_BLK = HIGH_BLK + 1
	    ELSE
		TBLK(HIGH_BLK)(HIGH_OFF+1:HIGH_OFF+2) = CHAR(13)//CHAR(10)
		HIGH_OFF = HIGH_OFF + 2
	    END IF
	END IF
	STORE_TEXT = 1
	RETURN
	END
C
	INTEGER FUNCTION SEND_STORED_TEXT ( LINK, WRITTEN )
C
C	Write previously stored text to HPSS link.
C
	IMPLICIT NONE
	INTEGER LINK, WRITTEN
	INTEGER I, STATUS, HPSS_WRITE, LENGTH
C
	INTEGER HIGH_BLK, HIGH_OFF
	CHARACTER*16384 TBLK(256)		! 4 megabytes.
	COMMON /NDX_STORE/ HIGH_BLK, HIGH_OFF, TBLK
C
	WRITTEN = 0
	LENGTH = LEN(TBLK(1))
	DO I = 1, HIGH_BLK
	    IF ( I .LT. HIGH_BLK ) THEN
		STATUS = HPSS_WRITE ( LINK, TBLK(I), 0 )
	    ELSE IF ( HIGH_OFF .GT. 0 ) THEN
C
C		Last block and it is non-zero.
C
		STATUS = HPSS_WRITE ( LINK, TBLK(I)(:HIGH_OFF), 0 )
		LENGTH = HIGH_OFF
	    END IF
C
	    IF ( .NOT. STATUS ) THEN
		SEND_STORED_TEXT = STATUS
		RETURN
	    END IF
	    WRITTEN = WRITTEN + LENGTH
	END DO
	SEND_STORED_TEXT = 1
	RETURN
C
	END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

	SUBROUTINE WEB_SERVER ( CONTEXT, FOLDER, MESSAGE_COUNT )
C
	IMPLICIT NONE
	INTEGER CONTEXT, MESSAGE_COUNT
	CHARACTER*(*) FOLDER
	INTEGER IN_ITEM(200), OUT_ITEM(200)
	INTEGER MAIL$MESSAGE_SELECT, SELECTED, LENGTH, STATUS, PLEN
	INTEGER HPSS_INITIALIZE, HPSS, PID, MSG_ID, OTS$CVT_TI_L, I
	INTEGER HPSS_ACCEPT, HPSS_DISCONNECT, HPSS_GETENV, HPSS_WRITE
	INTEGER SEND_STORED_TEXT, SEND_ROOT_PAGE
	CHARACTER SUBFUNC*16, VALUE*256, PATH*256
	CHARACTER*256 FROM, TO, SUBJ, HOST
	CHARACTER LINE*1024
	INTEGER FROM_LEN, TO_LEN, SUBJ_LEN, HOST_LEN, MAIL$MESSAGE_GET
	INTEGER STORE_TEXT
	INCLUDE '($MAILDEF)'
C
C	Select all items in folder and pregenerate 'index' page.
C
	LENGTH = 0
	CALL STR$TRIM ( FOLDER, FOLDER, LENGTH )
	CALL ITEM_SET ( IN_ITEM, 1, LENGTH, MAIL$_MESSAGE_FOLDER,
	1	%LOC(FOLDER), 0 )
	CALL ITEM_SET ( OUT_ITEM, 1, 4, MAIL$_MESSAGE_SELECTED,
	1	%LOC(SELECTED), 0 )
C
	STATUS = MAIL$MESSAGE_SELECT ( CONTEXT, IN_ITEM, OUT_ITEM )
	IF ( .NOT. STATUS ) 
	1	TYPE*,'Status of folder select:', STATUS, SELECTED
	IF ( .NOT. STATUS ) RETURN
C
	CALL LOAD_INDEX ( CONTEXT, SELECTED )
	CALL LIB$SHOW_TIMER()
C
C	Begin listening for script requests, mailbox HPSS_SRV_MAILDEMO,
C	assume server configured to wildcard accept /$hpsssrv/hpss_srv_*
C
	STATUS = HPSS_INITIALIZE ( 'HPSS_SRV_MAILDEMO', 0, HPSS )
	TYPE*,'HPSS_SRV_MAIL initialized with status:', STATUS
C
	DO WHILE ( STATUS )
C
	    STATUS = HPSS_ACCEPT ( HPSS, 0, PID, SUBFUNC )
	    IF ( STATUS ) THEN
C
C		The the path argument
C
		STATUS = HPSS_GETENV ( HPSS, 'PATH_INFO', PATH, PLEN )
		IF ( .NOT. STATUS ) THEN
		    PLEN = 0
		    PATH = '/'
		    MSG_ID = -1
		END IF
CC		TYPE*,'New connection: ',STATUS, ' path: ', PATH(:PLEN),
CC	1		MSG_ID
C
		IF ( PLEN .LE. 0 ) THEN
C
C		    No trailing slash on script name, redirect.
C
		    MSG_ID = -1
		    STATUS = HPSS_GETENV ( HPSS, 'SCRIPT_NAME', PATH, PLEN )
		    STATUS = HPSS_GETENV ( HPSS, 'HTTP_HOST', HOST, HOST_LEN )
		    IF ( .NOT. STATUS ) THEN
C
C			Client didn't supply host: header, user server name
C
			STATUS = HPSS_GETENV(HPSS, 'SERVER_NAME',HOST,HOST_LEN)
			STATUS = HPSS_GETENV(HPSS,'SERVER_PORT',TO, TO_LEN)
			IF ( TO(:TO_LEN) .NE. '80' ) THEN
			    HOST(HOST_LEN+1:) = ':'//TO(:TO_LEN)
			END IF
		    END IF
		    LENGTH = 0
		    CALL SYS$FAO ( 
	1		'Location: http://!AF!AF/!/!/', LENGTH, LINE,
	1		%VAL(HOST_LEN), %VAL(%LOC(HOST)),
	1		%VAL(PLEN), %VAL(%LOC(PATH)) )
		    STATUS = HPSS_WRITE ( HPSS, LINE(:LENGTH), 1 )
		ELSE IF ( PLEN .EQ. 1 ) THEN
		    STATUS = SEND_ROOT_PAGE ( HPSS )
		    MSG_ID = -1
	TYPE*,'Status of root page send:', STATUS
		ELSE IF ( PATH(:PLEN) .EQ. '/index' ) THEN
		    STATUS = SEND_STORED_TEXT ( HPSS, LENGTH )
	TYPE*,'Status of stored send and length:', STATUS, LENGTH
		    MSG_ID = -1
		ELSE
		    STATUS = HPSS_WRITE ( HPSS, 
	1			'Content-type: text/plain', 1 )
		    STATUS = HPSS_WRITE ( HPSS, CHAR(13)//CHAR(10), 0 )
		    STATUS = OTS$CVT_TI_L ( PATH(2:PLEN), MSG_ID )
		    IF ( .NOT. STATUS ) THEN
	TYPE*,'cvt error:', STATUS
			STATUS = HPSS_WRITE ( HPSS,
	1		    'Invalid message number: '//PATH(2:PLEN), 1)
			MSG_ID = -1
		    ELSE
		        STATUS = HPSS_WRITE ( HPSS, 
	1		    'Message '// PATH(2:PLEN),1)
		    END IF
		END IF
		IF ( MSG_ID .GE. 0 ) THEN
		   CALL ITEM_SET ( IN_ITEM, 1, 4, MAIL$_MESSAGE_ID,
	1		%LOC(MSG_ID), 0 )
		   CALL ITEM_SET ( OUT_ITEM, 1, 255,
	1		MAIL$_MESSAGE_SUBJECT, %LOC(SUBJ), %LOC(SUBJ_LEN) )
		    STATUS = MAIL$MESSAGE_GET(CONTEXT,IN_ITEM,OUT_ITEM)
		    IF ( .NOT. STATUS ) THEN
			TYPE*,'message get error: ', STATUS
			STATUS = HPSS_WRITE ( HPSS, 'Open error', 1 )
			MSG_ID = -1
		    ELSE 
		    END IF
		END IF
C
C		Dump the text.
C
		CALL ITEM_SET ( IN_ITEM, 1, 4, MAIL$_MESSAGE_CONTINUE,
	1		%LOC(MSG_ID), 0 )
		CALL ITEM_SET ( OUT_ITEM, 1, 255, MAIL$_MESSAGE_RECORD,
	1		%LOC(LINE), LOC(LENGTH) )
		DO WHILE ( MSG_ID .GE. 0 )
		    STATUS = MAIL$MESSAGE_GET(CONTEXT,IN_ITEM,OUT_ITEM)
		    IF ( STATUS ) THEN
			STATUS = HPSS_WRITE ( HPSS, LINE(:LENGTH), 1 )
			IF ( .NOT. STATUS ) MSG_ID = -1
		    ELSE
			MSG_ID = -1
		    END IF
		END DO
C
C		CLose connection
C
		STATUS = 1
		STATUS = HPSS_DISCONNECT ( HPSS )
	    END IF
C
	END DO
	TYPE*,'Final web_server status:', STATUS
	END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
	INTEGER FUNCTION SEND_ROOT_PAGE ( LINK )
	IMPLICIT NONE
	INTEGER LINK, STATUS, HPSS_WRITE, I, LENGTH
	CHARACTER*60 HTML(9) /
	1 'Content-type: text/html||',
	2 '<HTML><HEAD><TITLE>HPSS demo (mail)</TITLE></HEAD>|',
	3 '<FRAMESET ROWS="150,*">|',
	4  '<FRAME SRC="index" NAME="toc" SCROLLING="auto">|',
	5  '<FRAME SRC="1" NAME="msg" SCROLLING="auto">|',
	6  '</FRAMSET><NOFRAMES><BODY>|',
	7  'Your browser does not support frames link to |',
	8  '<A HREF="index">index</A> directly to see message list|',
	9  '</BODY></NOFRAMES>|' /
C
C	Send prepared text, checking for errors.
C
	DO I = 1, 9
	    LENGTH = INDEX(HTML(I),'|') - 1
	    IF ( HTML(I)(LENGTH+2:LENGTH+2) .EQ. '|' ) THEN
		HTML(I)(LENGTH+1:) = CHAR(13)//CHAR(10)//'|'
		LENGTH = LENGTH + 2
	    END IF
	    SEND_ROOT_PAGE = HPSS_WRITE ( LINK, HTML(I)(:LENGTH), 1 )
	    IF ( .NOT. SEND_ROOT_PAGE ) RETURN
	END DO
	SEND_ROOT_PAGE = 1
	END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C	Scan message folder and generate index of pages
C
	SUBROUTINE LOAD_INDEX ( MSGCTX, COUNT )
C
	IMPLICIT NONE
	INTEGER MSGCTX, COUNT, I, STATUS, MSG_ID, LENGTH, SYS$FAO
	INTEGER IN_ITEM(200), OUT_ITEM(200)
	CHARACTER*256 FROM, TO, SUBJ
	CHARACTER LINE*3072, ENC_LINE*3072
	INTEGER FROM_LEN, TO_LEN, SUBJ_LEN, MAIL$MESSAGE_GET, STORE_TEXT
	INTEGER I2, ENC_LEN, J, K, CODE
	CHARACTER*8 CODE_STR(3) / '&lt; ', '&amp; ', '&gt; ' /
	INCLUDE '($MAILDEF)'
C
C	Add CGI header.
C
	I=STORE_TEXT('Content-type: text/html', 1)
	I=STORE_TEXT(CHAR(13)//CHAR(10),0)	! blank line to end CGI header
	I=STORE_TEXT(
	1 '<HTML><HEAD><TITLE>HPSS demo (mail)</TITLE></HEAD><BODY>', 1 )
	I=STORE_TEXT('Messages in folder:', 1 )
C
C	Scan the folder.
C
	CALL ITEM_SET(IN_ITEM, 1, 4, MAIL$_MESSAGE_ID, %LOC(MSG_ID), 0)
	CALL ITEM_SET ( OUT_ITEM, 1, 255,
	1		MAIL$_MESSAGE_SUBJECT, %LOC(SUBJ), %LOC(SUBJ_LEN) )
	TYPE*,'Scanning', COUNT, ' headers...'
	
	DO MSG_ID = 1, COUNT
	    I = STORE_TEXT('<BR>',0)
	    STATUS = MAIL$MESSAGE_GET(MSGCTX,IN_ITEM,OUT_ITEM)
	    LENGTH = 0
	    IF ( .NOT. STATUS ) THEN
		CALL SYS$FAO ( '(Error getting message !SL information)',
	1		    LENGTH, LINE, %VAL(MSG_ID) )
		TYPE*,'message get error: ', STATUS
	    ELSE
C
C		URL-encode the subject string
C
		J = 0
		DO I2 = 1, SUBJ_LEN
		   CODE = INDEX ( '<&>', SUBJ(I2:I2) )
	           IF ( CODE .EQ. 0 ) THEN
		       J = J + 1
		       ENC_LINE(J:J) = SUBJ(I2:I2)
		    ELSE
		        K = 1
		        DO WHILE ( CODE_STR(CODE)(K:K) .NE. ' ' )
			    ENC_LINE(J+K:J+K) = CODE_STR(CODE)(K:K)
			    K = K + 1
		        END DO
		        J = J + K
		    END IF
	        END DO

		STATUS = SYS$FAO (
	1	    '<A HREF="!SL" target="msg">!AF</A>',
	1	    LENGTH, LINE, %VAL(MSG_ID), %VAL(J),
	2	    %VAL(%LOC(ENC_LINE)) )
		IF ( .NOT. STATUS ) TYPE*,'FAO error: ', STATUS
	    END IF
 	    I=STORE_TEXT ( LINE(:LENGTH), 1 )
	END DO
C
C	Add trailer.
C
	I=STORE_TEXT( '<P><HR></BODY></HTML>', 1 )
	END
