appl/lib/html.b

implement HTML;

include "sys.m";
include "html.m";
include "strinttab.m";

sys:	Sys;
T:	StringIntTab;

Stringtab: adt
{
	name:	string;
	val:		int;
};

chartab:= array[] of { T->StringInt
	("AElig", 'Æ'),
	("Aacute", 'Á'),
	("Acirc", 'Â'),
	("Agrave", 'À'),
	("Aring", 'Å'),
	("Atilde", 'Ã'),
	("Auml", 'Ä'),
	("Ccedil", 'Ç'),
	("ETH", 'Ð'),
	("Eacute", 'É'),
	("Ecirc", 'Ê'),
	("Egrave", 'È'),
	("Euml", 'Ë'),
	("Iacute", 'Í'),
	("Icirc", 'Î'),
	("Igrave", 'Ì'),
	("Iuml", 'Ï'),
	("Ntilde", 'Ñ'),
	("Oacute", 'Ó'),
	("Ocirc", 'Ô'),
	("Ograve", 'Ò'),
	("Oslash", 'Ø'),
	("Otilde", 'Õ'),
	("Ouml", 'Ö'),
	("THORN", 'Þ'),
	("Uacute", 'Ú'),
	("Ucirc", 'Û'),
	("Ugrave", 'Ù'),
	("Uuml", 'Ü'),
	("Yacute", 'Ý'),
	("aacute", 'á'),
	("acirc", 'â'),
	("acute", '´'),
	("aelig", 'æ'),
	("agrave", 'à'),
	("alpha", 'α'),
	("amp", '&'),
	("aring", 'å'),
	("atilde", 'ã'),
	("auml", 'ä'),
	("beta", 'β'),
	("brvbar", '¦'),
	("ccedil", 'ç'),
	("cdots", '⋯'),
	("cedil", '¸'),
	("cent", '¢'),
	("chi", 'χ'),
	("copy", '©'),
	("curren", '¤'),
	("ddots", '⋱'),
	("deg", '°'),
	("delta", 'δ'),
	("divide", '÷'),
	("eacute", 'é'),
	("ecirc", 'ê'),
	("egrave", 'è'),
	("emdash", '—'),
	("emsp", ' '),
	("endash", '–'),
	("ensp", ' '),
	("epsilon", 'ε'),
	("eta", 'η'),
	("eth", 'ð'),
	("euml", 'ë'),
	("frac12", '½'),
	("frac14", '¼'),
	("frac34", '¾'),
	("gamma", 'γ'),
	("gt", '>'),
	("iacute", 'í'),
	("icirc", 'î'),
	("iexcl", '¡'),
	("igrave", 'ì'),
	("iota", 'ι'),
	("iquest", '¿'),
	("iuml", 'ï'),
	("kappa", 'κ'),
	("lambda", 'λ'),
	("laquo", '«'),
	("ldots", '…'),
	("lt", '<'),
	("macr", '¯'),
	("micro", 'µ'),
	("middot", '·'),
	("mu", 'μ'),
	("nbsp", ' '),
	("not", '¬'),
	("ntilde", 'ñ'),
	("nu", 'ν'),
	("oacute", 'ó'),
	("ocirc", 'ô'),
	("ograve", 'ò'),
	("omega", 'ω'),
	("omicron", 'ο'),
	("ordf", 'ª'),
	("ordm", 'º'),
	("oslash", 'ø'),
	("otilde", 'õ'),
	("ouml", 'ö'),
	("para", '¶'),
	("phi", 'φ'),
	("pi", 'π'),
	("plusmn", '±'),
	("pound", '£'),
	("psi", 'ψ'),
	("quad", ' '),
	("quot", '"'),
	("raquo", '»'),
	("reg", '®'),
	("rho", 'ρ'),
	("sect", '§'),
	("shy", ''),
	("sigma", 'σ'),
	("sp", ' '),
	("sup1", '¹'),
	("sup2", '²'),
	("sup3", '³'),
	("szlig", 'ß'),
	("tau", 'τ'),
	("theta", 'θ'),
	("thinsp", ' '),
	("thorn", 'þ'),
	("times", '×'),
	("trade", '™'),
	("uacute", 'ú'),
	("ucirc", 'û'),
	("ugrave", 'ù'),
	("uml", '¨'),
	("upsilon", 'υ'),
	("uuml", 'ü'),
	("varepsilon", '∈'),
	("varphi", 'ϕ'),
	("varpi", 'ϖ'),
	("varrho", 'ϱ'),
	("vdots", '⋮'),
	("vsigma", 'ς'),
	("vtheta", 'ϑ'),
	("xi", 'ξ'),
	("yacute", 'ý'),
	("yen", '¥'),
	("yuml", 'ÿ'),
	("zeta", 'ζ'),
};

htmlstringtab := array[] of { T->StringInt
	("a", Ta),
	("address", Taddress),
	("applet", Tapplet),
	("area", Tarea),
	("att_footer", Tatt_footer),
	("b", Tb),
	("base", Tbase),
	("basefont", Tbasefont),
	("big", Tbig),
	("blink", Tblink),
	("blockquote", Tblockquote),
	("body", Tbody),
	("bq", Tbq),
	("br", Tbr),
	("caption", Tcaption),
	("center", Tcenter),
	("cite", Tcite),
	("code", Tcode),
	("col", Tcol),
	("colgroup", Tcolgroup),
	("dd", Tdd),
	("dfn", Tdfn),
	("dir", Tdir),
	("div", Tdiv),
	("dl", Tdl),
	("dt", Tdt),
	("em", Tem),
	("font", Tfont),
	("form", Tform),
	("frame", Tframe),
	("frameset", Tframeset),
	("h1", Th1),
	("h2", Th2),
	("h3", Th3),
	("h4", Th4),
	("h5", Th5),
	("h6", Th6),
	("head", Thead),
	("hr", Thr),
	("html", Thtml),
	("i", Ti),
	("img", Timg),
	("input", Tinput),
	("isindex", Tisindex),
	("item", Titem),
	("kbd", Tkbd),
	("li", Tli),
	("link", Tlink),
	("map", Tmap),
	("menu", Tmenu),
	("meta", Tmeta),
	("nobr", Tnobr),
	("noframes", Tnoframes),
	("ol", Tol),
	("option", Toption),
	("p", Tp),
	("param", Tparam),
	("pre", Tpre),
	("q", Tq),
	("samp", Tsamp),
	("script", Tscript),
	("select", Tselect),
	("small", Tsmall),
	("strike", Tstrike),
	("strong", Tstrong),
	("style", Tstyle),
	("sub", Tsub),
	("sup", Tsup),
	("t", Tt),
	("table", Ttable),
	("tbody", Ttbody),
	("td", Ttd),
	("textarea", Ttextarea),
	("textflow", Ttextflow),
	("tfoot", Ttfoot),
	("th", Tth),
	("thead", Tthead),
	("title", Ttitle),
	("tr", Ttr),
	("tt", Ttt),
	("u", Tu),
	("ul", Tul),
	("var", Tvar)
};

W, D, L, U, N: con byte (1<<iota);
NCTYPE: con 256;

ctype := array[NCTYPE] of {
	'0'=>D, '1'=>D, '2'=>D, '3'=>D, '4'=>D,
	'5'=>D, '6'=>D, '7'=>D, '8'=>D, '9'=>D,
	'A'=>U, 'B'=>U, 'C'=>U, 'D'=>U, 'E'=>U, 'F'=>U,
	'G'=>U, 'H'=>U, 'I'=>U, 'J'=>U, 'K'=>U, 'L'=>U,
	'M'=>U, 'N'=>U, 'O'=>U, 'P'=>U, 'Q'=>U, 'R'=>U,
	'S'=>U, 'T'=>U, 'U'=>U, 'V'=>U, 'W'=>U, 'X'=>U,
	'Y'=>U, 'Z'=>U,
	'a'=>L, 'b'=>L, 'c'=>L, 'd'=>L, 'e'=>L, 'f'=>L,
	'g'=>L, 'h'=>L, 'i'=>L, 'j'=>L, 'k'=>L, 'l'=>L,
	'm'=>L, 'n'=>L, 'o'=>L, 'p'=>L, 'q'=>L, 'r'=>L,
	's'=>L, 't'=>L, 'u'=>L, 'v'=>L, 'w'=>L, 'x'=>L,
	'y'=>L, 'z'=>L,
	'.'=>N, '-'=>N,
	' '=>W, '\n'=>W, '\t'=>W, '\r'=>W,
	* => byte 0
};

lex(b: array of byte, charset: int, keepwh: int): array of ref Lex
{
	if(sys == nil)
		sys = load Sys Sys->PATH;
	if(T == nil)
		T = load StringIntTab StringIntTab->PATH;
	if(T == nil) {
		sys->print("HTML->lex: couldn't %s\n", StringIntTab->PATH);
		return nil;
	}

	a: array of ref Lex;
	ai := 0;
	i := 0;
	nb := len b;
	for(;;){
   Whitespace:
		for(;;){
			# ignore nulls
			while(i<nb && (int b[i] == 0))
				i++;
			# skip white space
			if(!keepwh) {
				while(i<nb) {
					c := int b[i];
					if(!(int (ctype[c]&W)) && c != ' ')
						break;
					i++;
				}
			}
			# skip comments
			if(i<nb-4 && int b[i]=='<' && int b[i+1]=='!'
					&& int b[i+2]=='-' && int b[i+3]=='-') {
				i += 4;
				while(i<nb-3){
					if(int b[i]=='-' && int b[i+1]=='-' && int b[i+2]=='>'){
						i += 3;
						continue Whitespace;
					}
					i++;
				}
				continue Whitespace;
			}
			break;
		}
		if(i == nb)
			break;
		if(ai == len a){
			na := array[len a + 500] of ref Lex;
			if(a != nil)
				na[0:] = a;
			a = na;
		}
		if(int b[i] == '<'){
			lx : ref Lex;
			(lx, i) = gettag(b, i, charset);
			a[ai++] = lx;
		}
		else {
			s: string;
			(s, i) = getdata(b, i, keepwh, charset);
			a[ai++] = ref Lex (Data, s, nil);
		}
	}
	return a[0:ai];
}

getdata(b: array of byte, i: int, keepnls, charset: int): (string, int)
{
	s:= "";
	j:= 0;
	c: int;
	nb := len b;

loop:
	while(i < nb){
		oldi := i;
		case charset{
		Latin1 =>
			c = int b[i++];
		UTF8 =>
			j: int;
			(c, j, nil) = sys->byte2char(b, i);
			i += j;
		}
		case c {
		0 or 16r1a =>
			continue loop;
		'<' =>
			i = oldi;
			break loop;
		'&' =>
			(c, i) = ampersand(b, i);
		'\n' =>
			if(!keepnls)
				c = ' ';
		'\r' =>
			if(oldi > 0 && int b[oldi-1] == '\n')
				continue loop;
			if(keepnls)
				c = '\n';
			else
				c = ' ';
		}
		s[j++] = c;
	}
	return (s, i);
}

gettag(b: array of byte, i, charset: int): (ref Lex, int)
{
	rbra := 0;
	nb := len b;
	ans := ref Lex(Notfound, "", nil);
	al: list of Attr;
	if(++i == nb)
		return (ans, i);
	istart := i;
	c := int b[i];
	if(c == '/') {
		rbra = RBRA;
		if(++i == nb)
			return (ans, i);
		c = int b[i];
	}
	if(c>=NCTYPE || !int (ctype[c]&(L|U))) {
		while(i < nb) {
			c = int b[i++];
			if(c == '>')
				break;
		}
		ans.text = string b[istart:i];
		return (ans, i);
	}
	namstart := i;
	while(c<NCTYPE && int (ctype[c]&(L|U|D|N))) {
		if(++i == nb) {
			ans.text = string b[istart:i];
			return (ans, i);
		}
		c = int b[i];
	}
	name := lowercase(b, namstart, i);
	(fnd, tag) := T->lookup(htmlstringtab, name);
	if(fnd)
		ans.tag = tag+rbra;
	else
		ans.text = name;
attrloop:
	while(i < nb){
		# look for "ws name" or "ws name ws = ws val"  (ws=whitespace)
		# skip whitespace
		while(c<NCTYPE && int (ctype[c]&W)) {
			if(++i == nb)
				break attrloop;
			c = int b[i];
		}
		if(c == '>') {
			i++;
			break;
		}
		if(c == '<')
			break;	# error: unclosed tag
		if(c>=NCTYPE || !int (ctype[c]&(L|U))) {
			# error, not the start of a name
			# skip to end of tag
			while(i < nb) {
				c = int b[i++];
				if(c == '>')
					break;
			}
			break attrloop;
		}
		# gather name
		namstart = i;
		while(c<NCTYPE && int (ctype[c]&(L|U|D|N))) {
			if(++i == nb)
				break attrloop;
			c = int b[i];
		}
		name = lowercase(b, namstart, i);
		# skip whitespace
		while(c<NCTYPE && int (ctype[c]&W)) {
			if(++i == nb)
				break attrloop;
			c = int b[i];
		}
		if(c != '=') {
			# no value for this attr
			al = (name, "") :: al;
			continue attrloop;
		}
		# skip whitespace
		if(++i == nb)
			break attrloop;
		c = int b[i];
		while(c<NCTYPE && int (ctype[c]&W)) {
			if(++i == nb)
				break attrloop;
			c = int b[i];
		}
		# gather value
		quote := 0;
		if(c == '\'' || c == '"') {
			quote = c;
			i++;
		}
		val := "";
		nv := 0;
	valloop:
		while(i < nb) {
			case charset{
			Latin1 =>
				c = int b[i++];
			UTF8 =>
				j: int;
				(c, j, nil) = sys->byte2char(b, i);
				i += j;
			}
			if(c == '>') {
				if(quote) {
					# c might be part of string (though not good style)
					# but if line ends before close quote, assume
					# there was an unmatched quote
					for(k := i; k < nb; k++) {
						c = int b[k];
						if(c == quote) {
							val[nv++] = '>';
							continue valloop;
						}
						if(c == '\n') {
							i--;
							break valloop;
						}
					}
				}
				i--;
				break valloop;
			}
			if(quote) {
				if(c == quote)
					break valloop;
				if(c == '\n')
					continue valloop;
				if(c == '\t' || c == '\r')
					c = ' ';
			}
			else {
				if(c<NCTYPE && int (ctype[c]&W))
					break valloop;
			}
			if(c == '&')
				(c, i) = ampersand(b, i);
			val[nv++] = c;
		}
		al = (name, val) :: al;
		if(i < nb)
			c = int b[i];
	}
	ans.attr = al;
	return (ans, i);
}

ampersand(b: array of byte, i: int): (int, int)
{
	starti := i;
	c := 0;
	nb := len b;
	if(i >= nb)
		return ('?', i);
	fnd := 0;
	ans := 0;
	if(int b[i] == '#'){
		i++;
		while(i<nb){
			d := int b[i];
			if(!(int (ctype[d]&D)))
				break;
			c = c*10 + d-'0';
			i++;
		}
		if(0<c && c<256) {
			if(c==160)
				c = ' ';   # non-breaking space
			ans = c;
			fnd = 1;
		}
	}
	else {
		s := "";
		k := 0;
		c = int b[i];
		if(int (ctype[c]&(L|U))) {
			while(i<nb) {
				c = int b[i];
				if(!(int (ctype[c]&(L|U|D|N))))
					break;
				s[k++] = c;
				i++;
			}
		}
		(fnd, ans) = T->lookup(chartab, s);
	}
	if(!fnd)
		return ('&', starti);
	if(i<nb && (int b[i]==';' || int b[i]=='\n'))
		i++;
	return (ans, i);
}

lowercase(b: array of byte, istart, iend: int): string
{
	l := "";
	j := 0;
	for(i:=istart; i<iend; i++) {
		c := int b[i];
		if(c < NCTYPE && int (ctype[c]&U))
			l[j] = c-'A'+'a';
		else
			l[j] = c;
		j++;
	}
	return l;
}

uppercase(s: string): string
{
	l := "";

	for(i:=0; i<len s; i++) {
		c := s[i];
		if(c < NCTYPE && int (ctype[c]&L))
			l[i] = c+'A'-'a';
		else
			l[i] = c;
	}
	return l;
}

attrvalue(attr: list of Attr, name: string): (int, string)
{
	while(attr != nil){
		a := hd attr;
		if(a.name == name)
			return (1, a.value);
		attr = tl attr;
	}
	return (0, "");
}

globalattr(html: array of ref Lex, tag: int, attr: string): (int, string)
{
	for(i:=0; i<len html; i++)
		if(html[i].tag == tag)
			return attrvalue(html[i].attr, attr);
	return (0, "");
}

isbreak(h: array of ref Lex, i: int): int
{
	for(; i<len h; i++){
		case h[i].tag{
		Th1 or Th2 or Th3 or Th4 or Th5 or Th6 or
		Tbr or Tp or Tbody or Taddress or Tblockquote or
		Tul or Tdl or Tdir or Tmenu or Tol or Tpre or Thr or Tform =>
			return 1;
		Data =>
			return 0;
		}
	}
	return 0;
}

# for debugging
lex2string(l: ref Lex): string
{
	ans := "";
	tag := l.tag;
	if(tag == HTML->Data)
		ans = "'" + l.text + "'";
	else {
		ans = "<";
		if(tag >= RBRA) {
			tag -= RBRA;
			ans = ans + "/";
		}
		tname := T->revlookup(htmlstringtab, tag);
		if(tname != nil)
				ans = ans + uppercase(tname);
		for(al := l.attr; al != nil; al = tl al) {
			a := hd al;
			ans = ans + " " + a.name + "='" + a.value + "'";
		}
		ans = ans + ">";
	}
	return ans;
}