//www.s-and-b.ru/ht_root/doc/htdir/dir/

$!
$!			HTDIR.COM
$! This is an example DCL CGI+ script.
$! It has the same main functionality as the WASD directory listing
$! with HTdir script set features included.
$!
$ ON ERROR THEN GOTO ERROR_HANDLER
$ SET MESSAGE/NOFACILITY/NOSEVERITY/NOIDENTIFICATION/NOTEXT
$ HT_IDENT="HTdir V1.1C"
$ SAY:="WRITE/SYMBOL SYS$OUTPUT"
$ CGIUTL:=$CGI-BIN:[000000]CGIUTL
$ CGIEOF=F$TRNLNM("CGIPLUSEOF","LNM$PROCESS")
$ CGIESC=F$TRNLNM("CGIPLUSESC","LNM$PROCESS")
$ CGIEOT=F$TRNLNM("CGIPLUSEOT","LNM$PROCESS")
$ EMPTY="                                                                "
$ OPEN/READ/ERROR=IVENV CGIPLUSIN CGIPLUSIN:
$ IF CGIEOF .EQS. "" THEN GOTO CGI_VARS_END
$!
$ REQUEST_LOOP:
$ DELETE/SYMBOL/GLOBAL/ALL
$ READ/ERROR=DONE/END=DONE CGIPLUSIN LINE
$!
$ CGI_VARS_LOOP:
$ READ/ERROR=DONE/END=DONE CGIPLUSIN LINE
$ IF LINE .EQS. "" THEN GOTO CGI_VARS_END
$ CGI_VAR_NAME=F$ELEMENT(0,"=",LINE)
$ CGI_VAR_VALUE=LINE-(CGI_VAR_NAME+"=")
$ 'CGI_VAR_NAME'=="''CGI_VAR_VALUE'"
$ GOTO CGI_VARS_LOOP
$ CGI_VARS_END:
$!
$ UNICON=""
$ UPD=""
$ IF F$TYPE(WWW_FORM_UPD) .NES. "" THEN UPD="*"
$ IF WWW_REQUEST_METHOD .EQS. "POST" THEN UPD="*"
$ QUERY=""
$ IF F$TYPE(WWW_QUERY_STRING) .NES. "" THEN IF WWW_QUERY_STRING .NES. "" THEN -
    QUERY="?"+WWW_QUERY_STRING
$ TARG=""
$ IF F$TYPE(WWW_FORM_TARGET) .NES. "" THEN TARG=" TARGET="+WWW_FORM_TARGET
$!
$ IF WWW_PATH_INFO .EQS. ""
$   THEN
$   SAY "Location: //",WWW_SCRIPT_NAME,"/",QUERY
$   SAY ""
$   GOTO NEXT
$   ENDIF
$ LINE=F$PARSE(WWW_PATH_TRANSLATED,"*.*")
$ LINE=F$PARSE(LINE,,,"NAME")+F$PARSE(LINE,,,"TYPE")+F$PARSE(LINE,,,"VERSION")
$ IF F$LOCATE("*",LINE) .GE. F$LENGTH(LINE)
$   THEN
$   SAY "Location: ",WWW_PATH_INFO
$   SAY ""
$   GOTO NEXT
$   ENDIF
$!
$ IF WWW_REQUEST_METHOD .EQS. "POST" THEN -
    CGIUTL/URLDECODE/SYMBOLS/PREFIX=WWW_FORM
$ IF F$TYPE(WWW_FORM_SEL$$0) .EQS. ""
$   THEN
$   WWW_FORM_SEL$$0=="0"
$   IF F$TYPE(WWW_FORM_SEL) .NES. "" THEN WWW_FORM_SEL$$0=="1"
$   ENDIF
$!
$ SAY "Content-type: text/html"
$ SAY ""
$!
$ PEER=""
$ IF F$TYPE(WWW_FORM_DIR) .NES. ""
$   THEN
$   SAY CGIESC
$   SAY "MAP-PATH: ",WWW_FORM_DIR
$   SAY CGIEOT
$   READ CGIPLUSIN PEER
$   IF F$ELEMENT(0," ",PEER) .EQS. "200"
$     THEN
$     PEER=PEER-"200 "
$     PEER=F$EDIT(PEER,"TRIM")
$     ELSE
$     PEER=""
$     ENDIF
$   ENDIF
$!
$ SAY ""
$ SAY ""
$ SAY ""
$ SAY ""
$ SAY ""
$ SAY ""
$ SAY ""
$ IF UPD .NES. ""
$   THEN
$   SAY ""
$   ENDIF
$ SAY ""
$ LINE=""
$ IF F$TYPE(WWW_HTML_BODYTAG) .NES. "" THEN LINE=""
$ SAY LINE
$ IF F$TYPE(WWW_HTML_HEADERTAG) .NES. ""
$   THEN
$   LINE=WWW_HTML_HEADERTAG
$   IF (F$LENGTH(LINE) .EQ. 0) .OR. (F$LOCATE("<",LINE) .NE. 0) THEN -
      LINE="
"
$   SAY LINE
$   ENDIF
$ IF F$TYPE(WWW_HTML_HEADER) .NES. "" THEN SAY WWW_HTML_HEADER
$!
$ REF=WWW_SCRIPT_NAME+"/"
$ LINE="//"+WWW_HTTP_HOST+"/"
$ REST=WWW_PATH_INFO-"/"
$ HDR_LOOP:
$ IF F$ELEMENT(1,"/",REST) .EQS. "/" THEN GOTO HDR_END
$ TMP=F$ELEMENT(0,"/",REST)
$ REST=REST-TMP-"/"
$ REF=REF+TMP+"/"
$ LINE=LINE+""+TMP+"/"
$ GOTO HDR_LOOP
$ HDR_END:
$ SAY "
",LINE,"",REST,"","
"
$ LINE=F$PARSE(WWW_PATH_TRANSLATED,,,"DEVICE")+ -
       F$PARSE(WWW_PATH_TRANSLATED,,,"DIRECTORY")
$ IF F$SEARCH("''LINE'README.HTML") .NES. ""
$   THEN
$   TYPE 'LINE'README.HTML
$   ELSE
$   IF F$SEARCH("''LINE'README.TXT") .NES. ""
$     THEN
$     SAY "
"
$     TYPE 'LINE'README.TXT
$     SAY "
"
$     ENDIF
$   ENDIF
$!
$ IF F$TYPE(WWW_HTML_HEADERTAG) .NES. "" THEN SAY "
"
$ IF UPD .NES. ""
$   THEN
$   SAY "
"
$   ENDIF
$ SAY "
"
$!
$ SAY CGIESC
$ SAY "ICON-TYPE: x-internal/unknown"
$ SAY CGIEOT
$ READ CGIPLUSIN UNICON
$ IF F$ELEMENT(0," ",UNICON) .EQS. "200"
$   THEN
$   UNICON=UNICON-"200 "
$   UNICON=F$EDIT(UNICON,"TRIM")
$   ENDIF
$ SAY CGIESC
$ SAY "ICON-TYPE: x-internal/blank"
$ SAY CGIEOT
$ READ CGIPLUSIN ICON
$ IF F$ELEMENT(0," ",ICON) .EQS. "200"
$   THEN
$   ICON=ICON-"200 "
$   ICON=F$EDIT(ICON,"TRIM")
$   ELSE
$   ICON=UNICON
$   ENDIF
$ SAY CGIESC
$ SAY "ICON-TYPE: x-internal/directory"
$ SAY CGIEOT
$ READ CGIPLUSIN DIRICON
$ IF F$ELEMENT(0," ",DIRICON) .EQS. "200"
$   THEN
$   DIRICON=DIRICON-"200 "
$   DIRICON=F$EDIT(DIRICON,"TRIM")
$   ELSE
$   DIRICON=UNICON
$   ENDIF
$ IF UNICON .NES. "" THEN ICON=ICON+"  "
$!
$ BOX=""
$ IF UPD .NES. "" THEN -
    BOX=" "
$ SAY BOX,ICON,"Name                                Revised        Size","
"
$!
$ OLINE=""
$ FILE_LOOP:
$ LINE=F$SEARCH(F$PARSE(WWW_PATH_TRANSLATED,"*.*"),1)
$ IF LINE .EQS. "" THEN GOTO FILE_END
$ IF LINE .EQS. OLINE THEN GOTO FILE_END
$ OLINE=LINE
$ LINE=F$ELEMENT(0," ",F$EDIT(LINE,"TRIM"))
$ IF LINE .EQS. "" THEN GOTO FILE_LOOP
$ FSIZE=F$FAO("!10UL",F$FILE(OLINE,"EOF")*512)
$ FDATE=F$FILE(OLINE,"RDT")
$ FDATE=FDATE-(":"+F$ELEMENT(2,":",FDATE))
$ LINE=F$PARSE(LINE,,,"NAME")+F$PARSE(LINE,,,"TYPE")+F$PARSE(LINE,,,"VERSION")
$ IF F$PARSE(WWW_PATH_TRANSLATED,,,"VERSION") .EQS. ";" THEN -
    LINE=LINE-F$PARSE(LINE,,,"VERSION")
$ LINE=F$EDIT(LINE,"LOWERCASE")
$ REF=LINE
$ IF F$PARSE(LINE,,,"TYPE") .NES. ".DIR"
$   THEN
$   SAY CGIESC
$   SAY "ICON-TYPE: ",LINE
$   SAY CGIEOT
$   READ CGIPLUSIN ICON
$   IF F$ELEMENT(0," ",ICON) .EQS. "200"
$     THEN
$     ICON=ICON-"200 "
$     ICON=F$EDIT(ICON,"TRIM")
$     ELSE
$     ICON=UNICON
$     ENDIF
$   IF F$LENGTH(LINE) .GT. 24 THEN LINE=F$EXTRACT(0,23,LINE)+"+"
$   FILL=F$EXTRACT(0,24-F$LENGTH(LINE),EMPTY)
$   ELSE
$   LINE=F$PARSE(LINE,,,"NAME")
$   LINE=F$EDIT(LINE,"LOWERCASE")
$   LINE=LINE+"/"
$   NAM=LINE
$   REF=LINE+REST
$   ICON=DIRICON
$   IF F$LENGTH(LINE) .GT. 24 THEN LINE=F$EXTRACT(0,23,LINE)+"+"
$   FILL=F$EXTRACT(0,24-F$LENGTH(LINE),EMPTY)
$   LINE=""+LINE+""
$   FSIZE=F$FAO("!10UL",0)
$   ENDIF
$ IF UNICON .NES. "" THEN ICON=""+ICON+"  "
$ BOX=""
$ IF UPD .NES. "" THEN -
    BOX=" "
$ SAY "",BOX,ICON,"",LINE,"",FILL,"  ",FDATE,"  ",FSIZE
$ GOTO FILE_LOOP
$ FILE_END:
$!
$ SAY "
"
$ IF UPD .NES. "" THEN SAY "
"
$ IF F$TYPE(WWW_HTML_FOOTERTAG) .NES. ""
$   THEN
$   LINE=WWW_HTML_FOOTERTAG
$   IF (F$LENGTH(LINE) .EQ. 0) .OR. (F$LOCATE("<",LINE) .NE. 0) THEN -
      LINE="
"
$   SAY LINE
$   ENDIF
$ IF F$TYPE(WWW_HTML_FOOTER) .NES. "" THEN SAY WWW_HTML_FOOTER
$ IF F$TYPE(WWW_HTML_FOOTERTAG) .NES. "" THEN SAY "
"
$ SAY ""
$ SAY ""
$!
$ NEXT:
$ IF CGIEOF .NES. ""
$   THEN
$   SAY CGIEOF
$   GOTO REQUEST_LOOP
$   ENDIF
$ DONE:
$ CLOSE CGIPLUSIN
$ EXIT
$!
$ IVENV:
$ CALL ERROR_REPORT 500 "Invalid environment" "''HT_IDENT'"
$ GOTO DONE
$!
$ ERROR_HANDLER:
$ CALL ERROR_REPORT 500 "''F$FAO(F$MESSAGE($STATUS),"","","","")'" "''HT_IDENT'"
$ GOTO DONE
$!
$!	Error report subroutine.
$!	P1 - HTTP status (required)
$!	P2 - error text (required)
$!	P3 - module name (optional)
$!	P4 - line number (optional)
$!	Uses WASD Script-control: X-error-... extensions.
$!	If the current version doesn't support them,
$!	Then it will be a simple error report.
$!
$ ERROR_REPORT: SUBROUTINE
$ SAY "Status: ",P1
$ SAY "Script-control: X-error-text=""",P2,""""
$ IF P3 .NES. "" THEN SAY "Script-control: X-error-module=""",P3,""""
$ IF P4 .NES. "" THEN SAY "Script-control: X-error-line=",P4
$ SAY P1,": ",P2
$ EXIT
$ ENDSUBROUTINE