# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

include	<ctype.h>
include	"lroff.h"

define  DIRECTIVE       1			# processing codes
define  NAME            2
define  TEXT            3

define	F_ROMAN		1			# font changes
define	F_ITALIC	2
define	F_BOLD		3
define	F_PREVIOUS	4
define	F_TELETYPE	5			# HTML-specific font

define	SPTR		Memi[$1+$2]
define	SECTION		Memc[SPTR($1,$2)]
define	MAX_SECTIONS	256


# LROFF2HTML -- Convert LROFF text to HTML.  By default we process the
# entire file however we allow for the printing of only a particular section
# or labelled text block to be compatible with the HELP task options.
# If a section name is given that section will be printed and and .ls
# block request will be ignored.

procedure lroff2html (in, out, module, parstr, center, ls_block, section)

int	in					#I input file descriptor
int	out					#I output file descriptor
char	module[ARB]				#I .help module name
char	parstr[ARB]				#I .help optional keyword 2
char	center[ARB]				#I .help optional keyword 3
char	ls_block[ARB]				#I .ls block to search for
char	section[ARB]				#I section to print

pointer sp, ip, sptr
pointer ibuf, unesc, name, level
int	lastline, font, indented, ls_level
int	i, arg, nsec, cmd
bool	format, quit_at_le, quit_at_ih, formatted

int	lh_findsection(), lh_findblock(), nextcmd()
int	stridxs(), getline(), strlen(), strmatch(), getarg()

define	text_ 	99
define	err_ 	98

include	"lroff.com"

begin
	call smark (sp)
	call salloc (ibuf, SZ_IBUF, TY_CHAR)
	call salloc (unesc, SZ_IBUF, TY_CHAR)
	call salloc (name, SZ_LINE, TY_CHAR)
	call salloc (level, SZ_FNAME, TY_CHAR)
	call salloc (sptr, MAX_SECTIONS, TY_POINTER)

	call aclrc (Memc[ibuf], SZ_IBUF)
	call aclrc (Memc[name], SZ_LINE)
	call aclrc (Memc[unesc], SZ_IBUF)
	call aclrc (Memc[level], SZ_FNAME)

	# Initialize.
	lastline  = TEXT
	font 	  = F_ROMAN
	indented  = YES
	nsec 	  = 0
	ls_level  = 0
        format    = true
	quit_at_le = false
	quit_at_ih = false
        formatted  = false

	# Initialize the section numbering.
	call amovki (0, nh_level, MAX_NHLEVEL)

        # Determine whether or not the text is formatted.
        repeat {
            if (getline (in, Memc[ibuf]) == EOF)
                goto err_
            for (ip=1;  IS_WHITE(Memc[ibuf+ip-1]);  ip=ip+1)
               ;
        } until (Memc[ibuf+ip-1] != '\n')
        call ungetline (in, Memc[ibuf])
        if (Memc[ibuf] == '.')
           formatted = true

	# Scan forward if searching for and item.
	if (section[1] != EOS) {
	    if (lh_findsection (in, formatted, section) == EOF)
		goto err_
	} else if (ls_block[1] != EOS) {
	    if (lh_findblock (in, formatted, ls_block) == EOF)
		goto err_
	    quit_at_le = true
	}

	# Begin the output.
	call lh_prolog (out, module, parstr, center)
	call fprintf (out, "<TITLE>%s</TITLE>\n<UL>\n")
	    if (ls_block[1] != EOS)
		call pargstr (ls_block)
	    else if (section[1] != EOS)
		call pargstr (section)
	    else if (module[1] != EOS)
		call pargstr (module)
	    else
		call pargstr (" ")


	# Process the file.
	while (getline (in, Memc[ibuf]) != EOF) {

	    # Make a copy of the raw line minus the newline char, we may need
	    # this to extract comments later.
	    Memc[ibuf+strlen(Memc[ibuf])-1] = EOS
	    call strcpy (Memc[ibuf], Memc[unesc], SZ_LINE)


	    # Escape problem chars for HTML and handle font changes. Changes
	    # are done in-place.
	    call lh_escape (Memc[ibuf], font, format, NO, SZ_LINE)

	    switch (Memc[ibuf]) {
	    case '\n':
		call fprintf (out, "<P>\n")

	    case '.':
		# Swallow any help strings if present.
		if (strmatch (Memc[ibuf], "^.help") > 0)
		    next

		ip = 1
		lastline = TEXT

		# Process the directive, position the ip at the beginning
		# of any argument.
		cmd = nextcmd (Memc[ibuf], ip)
                while (IS_WHITE(Memc[ibuf+ip]))		# skip spaces
                    ip = ip + 1

		switch (cmd) {
		case FI:		# enter fill mode
		    call fprintf (out, "</PRE>\n")
		    format = true
		case NF:		# leave fill mode (nofill)
		    call fprintf (out, "<PRE>\n")
		    format = false
		case JU:		# enter line justification mode
		    # no-op
		    next
		case NJ:		# leave line justification mode
		    # no-op
		    next
		case RJ:		# right justify text on nf,nj line
		    # no-op
		    next

		case SH:		# section heading
		    if (ls_level > 0) {	# for missing .le statements
		        call fprintf (out, "</DD>\n</DL>\n")
		        ls_level = 0
		    }
		    lastline = DIRECTIVE
       	    	    Memc[level] = EOS
		    next
		case IH:		# indented section heading
		    if (ls_level > 0) {	# for missing .le statements
		        call fprintf (out, "</DD>\n</DL>\n")
		        ls_level = 0
		    }
		    lastline = DIRECTIVE
       	    	    Memc[level] = EOS
		    if (quit_at_ih)
			if (stridxs ("|", section) > 0) {
			    quit_at_ih = false
			    call ungetline (in, Memc[ibuf])
			    if (lh_findsection (in, formatted, section) == EOF)
		    	        break
			} else
		    	    break
		    next
		case NH:		# numbered section heading
		    if (ls_level > 0) {	# for missing .le statements
		        call fprintf (out, "</DD>\n</DL>\n")
		        ls_level = 0
		    }
		    call lh_set_level (getarg(Memc[ibuf],ip,1), Memc[level])
		    lastline = DIRECTIVE
		    next

		case CE:		# center next line
		    if (getline (in, Memc[ibuf]) == EOF)
			break
		    else {
	    	        call lh_escape (Memc[ibuf], font, true, NO, SZ_LINE)
		        call fprintf (out, "<CENTER>%s</CENTER><BR>\n")
		            call pargstr (Memc[ibuf])
		    }

		case BR:		# break line
		    call fprintf (out, "<BR>\n")
		case SP:		# break, space N spaces on output
		    arg = getarg (Memc[ibuf], ip, 1)
		    call fprintf (out, "<BR>\n")
		    for (i=1; i < arg; i = i + 1)
		        call fprintf (out, "<BR>\n")
		case IN:		# indent +/- N spaces
		    # no-op
		    next

		case LS:		# begin labelled section
		    arg = getarg (Memc[ibuf], ip, 0)
		    if (arg == 0) 
			ip = 5

		    # Generate a HREF of the label, we use only the first word.
		    call strcpy (Memc[ibuf+ip-1], Memc[name], SZ_LINE)
		    for (i=0; IS_ALNUM(Memc[name+i]) || 
				Memc[name+i] == '_'; i=i+1)
			    	    ;
		    Memc[name+i] = EOS
	    	    Memc[ibuf+ip+strlen(Memc[ibuf+ip])-1] = EOS

		    call fprintf (out, "<DL>\n<DT><B>")
		    call fprintf (out,"<A NAME=\"l_%s\">%s</A>")
		        call pargstr (Memc[name])
		        call pargstr (Memc[ibuf+ip-1])
		    call fprintf (out, "</B></DT>\n")

		    # Write out a comment line for the GUI to use.
	    	    call lh_escape(Memc[unesc+ip-1], font, true, YES, SZ_LINE)
	    	    Memc[unesc+strlen(Memc[unesc])-1] = EOS
		    call fprintf (out, 
			"<! Sec=%s Level=%d Label=\'%s\' Line=\'%s\'>\n<DD>")
			    if (nsec > 0)
		                call pargstr (SECTION(sptr, nsec-1))
			    else
		                call pargstr ("None")
		            call pargi (ls_level)
		            call pargstr (Memc[name])
			    if (Memc[unesc+ip-1] == '\n')
		                call pargstr (" ")
			    else
		                call pargstr (Memc[unesc+ip-1])
		    ls_level = ls_level + 1

		case LE:		# end labelled section
		    call fprintf (out, "</DD>\n</DL>\n")
		    ls_level = ls_level - 1
		    if (quit_at_le)
			break

                case HR:		# HREF anchor
                    # HTML href anchor of the form ".hr <href> <anch_text>",
		    # we skip ahead to the <text> and process as a normal line.
	    	    Memc[ibuf+ip+strlen(Memc[ibuf+ip])-1] = EOS
                    for (i=0; !IS_WHITE(Memc[ibuf+ip]); ip=ip+1) {
			Memc[name+i] = Memc[ibuf+ip]
                        i = i + 1
		    }
		    Memc[name+i] = EOS

		    call fprintf (out, "<A HREF=\"%s\">%s</A>\n")
		        call pargstr (Memc[name])
		        call pargstr (Memc[ibuf+ip+1])

                case HN:		# NAME target
                    # HTML name target of the form ".hn <name>", strip the
		    # newline added in the escape routine.
	    	    Memc[ibuf+ip+strlen(Memc[ibuf+ip])-1] = EOS
		    call fprintf (out, "<A NAME=\"%s\"></A>\n")
			call pargstr (Memc[ibuf+ip])

		case BP:		# break page
		    # no-op
		    next
		case TP:		# test space left on page
		    # no-op
		    next
		case KS:		# start floating keep
		    call fprintf (out, "<PRE>\n")
		    format = false
		case KE:		# end floating keep
		    call fprintf (out, "</PRE>\n")
		    format = true
		case ENDHELP:		# end of help block
		    break
		}

	    default:
		if (lastline == DIRECTIVE) {

		    # Section directive name.  For certain standard sections
		    # we'll force an indention to make the output look better,
		    # everything else gets written normally.

		    # Save the section name.
		    call salloc (SPTR(sptr,nsec), SZ_LINE, TY_CHAR)
	    	    call aclrc (SECTION(sptr,nsec), SZ_LINE)
	    	    Memc[ibuf+strlen(Memc[ibuf])-1] = EOS
		    call sprintf (SECTION(sptr,nsec), SZ_LINE, "\'%s\'")
			call pargstr (Memc[ibuf])

		    if (indented == YES)
		        call fprintf (out, "</UL>\n")
		    if (nsec > 0) {
		        call fprintf (out, "<! EndSection:   %s>\n")
		            call pargstr (SECTION(sptr,nsec-1))
		    }

		    # Make the section name a URL target.
		    call lh_mkname (Memc[ibuf], Memc[name])
		    if (Memc[level] == EOS) {
		        call fprintf (out, "<H2><A NAME=\"s_%s\">%s</A></H2>\n")
			    call pargstr (Memc[name])
			    call pargstr (Memc[ibuf])
		    } else {
		        call fprintf (out,
			    "<H2><A NAME=\"s_%s\">%s %s</A></H2>\n")
			    	call pargstr (Memc[name])
			    	call pargstr (Memc[level])
			    	call pargstr (Memc[ibuf])
       	    	    	Memc[level] = EOS
		    }

		    call fprintf (out, "<! BeginSection: \'%s\'>\n")
		        call pargstr (Memc[ibuf])
		    if (indented == YES)
		        call fprintf (out, "<UL>\n")

		    lastline = NAME
		    nsec = nsec + 1
		    if (section[1] != EOS)
	    	 	quit_at_ih = true

		} else {
		    # Ordinary text line.
text_	    	    call fprintf (out, "%s")
	   	        call pargstr (Memc[ibuf])
		    lastline = TEXT
		}
	    }

	    call aclrc (Memc[ibuf], SZ_IBUF)
	    call aclrc (Memc[unesc], SZ_IBUF)
	    call aclrc (Memc[name], SZ_LINE)
	}

	# Close the last section.
	if (nsec > 0) {
	    call fprintf (out, "</UL>\n<! EndSection:    %s>\n\n")
                call pargstr (SECTION(sptr,nsec-1))
	}

	# Write out an HTML comment giving the document section names.
	call fprintf (out, "<! Contents: ")
	for (i=0; i < nsec; i=i+1) {
	    call fprintf (out, "%s ")
		call pargstr (SECTION(sptr,i))
	}
	call fprintf (out, " >\n\n")
	call fprintf (out, "</BODY>\n</HTML>\n")

	call flush (out)
err_	call sfree (sp)
end


# LH_PROLOG --  Begin the HTML output, print the header table for a help
# page if we have the information.

procedure lh_prolog (fd, mod, date, title)

int	fd					#I output file descriptor
char	mod[ARB]				#I .help module name
char	date[ARB]				#I .help keyword 2
char	title[ARB]				#I .help keyword 3

begin
        call fprintf (fd, "<HTML>\n<BODY>\n")

	# If we only have the module name don't bother with header.
	if (date[1] == EOS && title[1] == EOS)
	    return

	# Begin the HTML output prolog.
        call fprintf (fd, "<TABLE WIDTH=\"100%%\" BORDER=0><TR>\n")

	# Left side page header.
        call fprintf (fd, "<TD ALIGN=LEFT><FONT SIZE=4>\n")
	if (date[1] == EOS) {
            call fprintf (fd, "<B>%s</B>")
                call pargstr (mod)
	} else {
            call fprintf (fd, "<B>%s (%s)</B>")
                call pargstr (mod)
                call pargstr (date)
	}
        call fprintf (fd, "</FONT></TD>\n")

	# Center page header.
	if (title[1] != EOS) {
            call fprintf (fd, "<TD ALIGN=CENTER><FONT SIZE=4>\n")
            call fprintf (fd, "<B>%s</B>\n")
                call pargstr (title)
            call fprintf (fd, "</FONT></TD>\n")
	}

	# Right side page header.
        call fprintf (fd, "<TD ALIGN=RIGHT><FONT SIZE=4>\n")
	if (date[1] == EOS) {
            call fprintf (fd, "<B>%s</B>")
                call pargstr (mod)
	} else {
            call fprintf (fd, "<B>%s (%s)</B>")
                call pargstr (mod)
                call pargstr (date)
	}
        call fprintf (fd, "</FONT></TD>\n")

        call fprintf (fd, "</TR></TABLE><P>\n")
end


# LH_ESCAPE -- Escape any HTML problem characters in the line ('<','>','&')
# as well as the font changes.

procedure lh_escape (str, font, format, special_only, maxch)

char	str[ARB]				#I string to edit
int	font					#U current font
bool	format					#I formatting flag
int	special_only				#I escape only special chars?
int	maxch					#I max length of string

pointer	sp, ip, buf, keyword
int	i, gstrcpy(), stridx()

define	copy_	90

begin
	call smark (sp)
	call salloc (buf, maxch, TY_CHAR)
	call salloc (keyword, maxch, TY_CHAR)
	call aclrc (Memc[buf], maxch)
	call aclrc (Memc[keyword], maxch)

	ip = buf
	for (i=1; str[i] != EOS && i <= maxch; i = i + 1) {

	    if (special_only == YES && stridx (str[i], "<>&") == 0)
		goto copy_

	    switch (str[i]) {

	    # Handle special chars.
	    case '<':
		ip = ip + gstrcpy ("&lt;", Memc[ip], SZ_LINE)
	    case '>':
		ip = ip + gstrcpy ("&gt;", Memc[ip], SZ_LINE)
	    case '&':
		ip = ip + gstrcpy ("&amp;", Memc[ip], SZ_LINE)

	    # Quoted single chars and strings get a special font.
	    case '\'':
		if (str[i+2] == '\'') {
		    ip = ip + gstrcpy ("<TT>",  Memc[ip], SZ_LINE)
		    ip = ip + gstrcpy (str[i],  Memc[ip], 3)
		    ip = ip + gstrcpy ("</TT>", Memc[ip], SZ_LINE)
		    i = i + 2
		} else
		    goto copy_
	    case '`':
		if (str[i+2] == '`' || str[i+2] == '\'') {
		    ip = ip + gstrcpy ("<TT>",  Memc[ip], SZ_LINE)
		    ip = ip + gstrcpy (str[i],  Memc[ip], 3)
		    ip = ip + gstrcpy ("</TT>", Memc[ip], SZ_LINE)
		    i = i + 2
		} else
		    goto copy_
	    case '"':
		if (format) {
		    if (font == F_TELETYPE) {
		        # Do a closing quote.
		        ip = ip + gstrcpy ("</TT>\"", Memc[ip], SZ_LINE)
		        font = F_ROMAN
		    } else if (font == F_ROMAN) {
		        # Do an opening quote.
		        ip = ip + gstrcpy ("\"<TT>", Memc[ip], SZ_LINE)
		        font = F_TELETYPE
		    } else
		        goto copy_
		} else 
		    goto copy_

	    # Process font changes.
	    case '\\':
		if (str[i+1] == 'f') {
		    if (str[i+2] == 'B') {
			if (font == F_BOLD)
			    next
			if (font == F_ITALIC)
			    ip = ip + gstrcpy ("</I>", Memc[ip], SZ_LINE)
			ip = ip + gstrcpy ("<B>", Memc[ip], SZ_LINE)
			font = F_BOLD

		    } else if (str[i+2] == 'I') {
			if (font == F_ITALIC)
			    next
			if (font == F_BOLD)
			    ip = ip + gstrcpy ("</B>", Memc[ip], SZ_LINE)
			ip = ip + gstrcpy ("<I>", Memc[ip], SZ_LINE)
			font = F_ITALIC

		    } else if (str[i+2] == 'R') {
			if (font == F_BOLD)
			    ip = ip + gstrcpy ("</B>", Memc[ip], SZ_LINE)
			else if (font == F_ITALIC)
			    ip = ip + gstrcpy ("</I>", Memc[ip], SZ_LINE)
			font = F_ROMAN

		    } else if (str[i+2] == 'P') {
			if (font == F_BOLD) {
			    ip = ip + gstrcpy ("</B>", Memc[ip], SZ_LINE)
			} else if (font == F_ITALIC) {
			    ip = ip + gstrcpy ("</I>", Memc[ip], SZ_LINE)
			}
			font = F_ROMAN
		    }
		    i = i + 2
		} else if (str[i+1] == '\n' || str[i+1] == EOS) {
		    Memc[ip] = str[i]
		    ip = ip + 1
		    i = i + 1
		    ip = ip + gstrcpy ("<BR>", Memc[ip], SZ_LINE)
		} else
		    goto copy_

	    default:
copy_		Memc[ip] = str[i]
		ip = ip + 1
	    }
	}

	# Add the trailing newline we stripped above.
	ip = ip + gstrcpy ("\n\0", Memc[ip], SZ_LINE)

	# Move the string back.
	call amovc (Memc[buf], str, maxch)

	call sfree (sp)
end


# LH_SET_LEVEL -- Increment the level number of a numbered header.

procedure lh_set_level (n, level)

int	n					#I level number
char	level[ARB]				#U level string

int	i, strlen()
include	"lroff.com"

begin
        # Increment the desired section number; zero all higher
	# numbered section counters.
        nh_level[n] = nh_level[n] + 1
        call amovki (0, nh_level[n+1], MAX_NHLEVEL - n)

        # Output the section number followed by a blank and then
	# the section label.
	level[1] = EOS
        do i = 1, n {
	    call sprintf (level[strlen(level)+1], SZ_IBUF, "%d.")
	        call pargi (nh_level[i])
	}

        # Cancel the final "." if subsection heading.  Add a blank.
        if (n > 1 && level[strlen(level)] == '.')
            level[strlen(level)] = EOS
end


# LH_FINDBLOCK -- If text contains format directives, eat input lines until
# a ".ls" directive is found which contains the block name as a substring.
# If the text is not formatted, search for a line beginning with the pattern.

int procedure lh_findblock (fd, formatted, param)

int	fd
bool	formatted
char	param[ARB]

bool	match_found
pointer	sp, lbuf, pattern
int	len
int	getline(), strmatch(), strlen()
errchk	getline

define	err_	90

begin
	call smark (sp)
	call salloc (pattern, SZ_FNAME, TY_CHAR)
	call salloc (lbuf, SZ_LINE, TY_CHAR)

	match_found = false

	# Get the first line.
	if (getline (fd, Memc[lbuf]) == EOF)
	    goto err_

	if (formatted) {
	    call sprintf (Memc[pattern], SZ_FNAME, "{%s}")
		call pargstr (param)
	    repeat {
		if (strmatch (Memc[lbuf], "^.{ls}") > 0)
		    if (strmatch (Memc[lbuf], Memc[pattern]) > 0) {
			match_found = true
			break
		    }
	    } until (getline (fd, Memc[lbuf]) == EOF)

	} else {
	    call sprintf (Memc[pattern], SZ_FNAME, "^#{%s}")
		call pargstr (param)
	    repeat {
		if (strmatch (Memc[lbuf], Memc[pattern]) > 0) {
		    match_found = true
		    break
		}
	    } until (getline (fd, Memc[lbuf]) == EOF)
	}
        call ungetline (fd, Memc[lbuf])

err_	len = strlen (Memc[lbuf])
	call sfree (sp)
	if (match_found)
	    return (len)
	else
	    return (EOF)
end


# LH_FINDSECTION -- If text contains format directives, eat input lines until
# a ".ih" directive is found for the named section.  If the text is not
# formatted, search for a line beginning with the section name.

define	MAXPAT		10

int procedure lh_findsection (fd, formatted, sections)

int	fd			# input file
bool	formatted		# is help block formatted
char	sections[ARB]		# list of sections "a|b|c"

bool	match_found
int	npat, ip
pointer	sp, patbuf, patoff[MAXPAT], op
char	lbuf[SZ_LINE]

bool	lh_match()
int	getline(), strmatch()
errchk	getline

define	err_	91

begin
	call smark (sp)
	call salloc (patbuf, SZ_LINE, TY_CHAR)

	# Process the list of sections into patbuf and patoff, i.e., into a
	# list of EOS delimited strings in the string buffer patbuf.  Each
	# section name or abbreviation is delimited by '|' (or).

	npat = 1
	op = patbuf
	patoff[1] = op

	# Get the first line.
	if (getline (fd, lbuf) == EOF)
	    goto err_

	for (ip=1;  sections[ip] != EOS;  ip=ip+1)
	    switch (sections[ip]) {
	    case '|':
		Memc[op] = EOS
		op = op + 1
		npat = min (MAXPAT, npat + 1)
		patoff[npat] = op
	    default:
		Memc[op] = sections[ip]
		op = op + 1
	    }
	Memc[op] = EOS

	match_found = false

	if (formatted) {
	    repeat {
		if (strmatch (lbuf, "^.{ih}") > 0)
		    if (getline (fd, lbuf) != EOF) {
			match_found = lh_match (lbuf, patoff, npat)
			if (match_found)
			    break
		    }
	    } until (getline (fd, lbuf) == EOF)
            call ungetline (fd, lbuf)
	    call ungetline (fd, ".ih\n")

	} else {
	    repeat {
		match_found = lh_match (lbuf, patoff, npat)
		if (match_found)
		    break
	    } until (getline (fd, lbuf) == EOF)
            call ungetline (fd, lbuf)
	}

err_	call sfree (sp)
        if (match_found)
            return (OK)
        else
            return (EOF)
end


# LH_MATCH -- Match a set of patterns against a line of test, matching only
# at the beginning of line in either case.

bool procedure lh_match (lbuf, patoff, npat)

char    lbuf[ARB]               # line of text
pointer patoff[npat]            # pointers to pattern strings
int     npat                    # number of patterns

int     pat
pointer sp, pattern
int     strmatch()

begin
        call smark (sp)
        call salloc (pattern, SZ_FNAME, TY_CHAR)

        for (pat=1;  pat <= npat;  pat=pat+1) {
            call sprintf (Memc[pattern], SZ_FNAME, "^{%s}")
                call pargstr (Memc[patoff[pat]])
            if (strmatch (lbuf, Memc[pattern]) > 0) {
        	call sfree (sp)
                return (true)
	    }
        }

        call sfree (sp)
        return (false)
end


# LH_MKNAME -- Given a string make it suitable for use as an HREF name.

procedure lh_mkname (instr, outstr)

char	instr[ARB]
char	outstr[ARB]

int	i

begin
	# Make it a URL.  First convert the section name to a
	# lower-case string and replace the blanks.
	call strcpy (instr, outstr, SZ_LINE)
	call strlwr (outstr)
	for (i=1; i < SZ_LINE; i=i+1)
	    if (outstr[i] == EOS || outstr[i] == '\n')
		break
	    else if (!IS_ALNUM(outstr[i]))
	        outstr[i] = '_'
end
