<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;">
=head1 kdocHTMLutil - Common HTML routines.

=cut

package kdocHTMLutil;

use kdocAstUtil;
use Carp;
use Iter;
use kdocDocIter;
use strict;
no strict qw/ subs/;
 
use vars qw( $VERSION @ISA @EXPORT $rcount $docNode $rootnode $comp *CLASS 
	$allowhtml %escmap %urlescmap);

BEGIN {
	$VERSION = '$Revision: 1.17 $';
	@ISA = qw( Exporter );
	@EXPORT = qw( makeReferences refName refNameFull refNameEvery hyper 
			esc printDoc printTextItem wordRef textRef deref 
			encodeURL newPgHeader tabRow makeHeader 
			HeaderPathToHTML writeTable makeSourceReferences B);

	$rcount = 0;
	$allowhtml = 0;

	%escmap = ( '&lt;' =&gt; '&amp;lt;', '&gt;' =&gt; '&amp;gt;', '&amp;' =&gt; '&amp;amp;' );
	%urlescmap = ( ':' =&gt; '%3A', '&lt;' =&gt; '%3C', '&gt;' =&gt; '%3E',
			' ' =&gt; '%20', '%' =&gt; '%25' );

}

sub allowHTML
{
	$allowhtml = shift;
}

## generic HTML generator routines

sub newPgHeader
{
	my ( $html, $heading, $desc, $rest, $toclist ) = @_; 
	my $bw=0;
	my $cspan = defined $main::options{"html-logo"} ? 2 : 1;
	my $stylesheet = $main::options{"html-css"};

	if ( defined $stylesheet ) {
		$stylesheet = '&lt;LINK REL="STYLESHEET" HREF="'.$stylesheet.'"&gt;'
	}
	else {
		$stylesheet = "";
	}

	print $html &lt;&lt;EOF;
&lt;HTML&gt;
&lt;HEAD&gt;
&lt;TITLE&gt;$heading&lt;/TITLE&gt;
$stylesheet
&lt;META NAME="Generator" CONTENT="KDOC $main::version"&gt;
&lt;/HEAD&gt;
&lt;BODY bgcolor="#ffffff" text="#000000" link="#0000ff" vlink="#000099" alink= "#ffffff"&gt;
&lt;TABLE WIDTH="100%" BORDER="$bw"&gt;
&lt;TR&gt;
&lt;TD&gt;
	&lt;TABLE BORDER="$bw"&gt;
		&lt;TR&gt;&lt;TD valign="top" align="left" cellspacing="10"&gt;
		&lt;h1&gt;$heading&lt;/h1&gt;
		&lt;/TD&gt;
		&lt;TD valign="top" align="right" colspan="1"&gt;$desc&lt;/TD&gt;&lt;/TR&gt;
	&lt;/TABLE&gt;
	&lt;HR&gt;
	&lt;TABLE BORDER="$bw"&gt;
		$rest
	&lt;/TABLE&gt;
	&lt;/TD&gt;
EOF

#	print $html '&lt;TABLE BORDER="',$bw,'"&gt;&lt;TR&gt;&lt;TD&gt;';
	my @klist = keys %$toclist;

	print $html '&lt;TD align="right"&gt;&lt;TABLE BORDER="',$bw,'"&gt;';

	# image
	print $html '&lt;TD rowspan="', ($#klist)+2,'"&gt;&lt;IMG SRC="',
			$main::options{"html-logo"},'"&gt;&lt;/TD&gt;'
		if defined $main::options{"html-logo"};

	# TOC

	foreach my $item ( sort @klist ) {
		print $html '&lt;TR&gt;&lt;TD&gt;',
		'&lt;small&gt;&lt;A HREF="',$toclist-&gt;{$item},'"&gt;',
			$item, "&lt;/A&gt;&lt;/small&gt;&lt;/TD&gt;&lt;/TR&gt;\n";
	}

	print $html "&lt;/TABLE&gt;&lt;/TD&gt;&lt;/TR&gt;&lt;/TABLE&gt;\n";
	
}

sub writeTable
{
	my ( $file, $list, $columns ) = @_;

	my ( $ctr, $size ) = ( 0, int(($#$list+1)/$columns) );
	$size = 1 if $size &lt; 1;

# spread out unallocated items across columns.
# The old behaviour was to dump them in the last column.
	my $s = $size * $columns;
	$size++ if $s &lt; ($#$list+1);

	print $file '&lt;TABLE WIDTH="100%" BORDER="0"&gt;&lt;TR&gt;';

	while ( $ctr &lt;= $#$list ) {
		print $file '&lt;TD VALIGN="top"&gt;';
		$s = $ctr+$size-1;

		if ( $s &gt; $#$list ) {
			$s = $#$list;
		}
		elsif ( ($#$list - $s) &lt; $columns) {
			$s = $#$list;
		}

		writeListPart( $file, $list, $ctr, $s );
		print $file "&lt;/TD&gt;";
		$ctr = $s+1;
	}

	print $file '&lt;/TR&gt;&lt;/TABLE&gt;';
}

=head2

	Parameters: fd, list, start index, end index

	Helper for writeClassList.  Prints a table containing a
	hyperlinked list of all nodes in the list from start index to
	end index. A table header is also printed.

=cut

sub writeListPart
{
	my( $file, $list, $start, $stop ) = @_;

	print $file "&lt;TABLE BORDER=\"0\"&gt;";

	print $file '&lt;TR bgcolor="b0b0b0"&gt;&lt;TH&gt;', 
		$list-&gt;[ $start ]-&gt;{astNodeName},
		" - ", $list-&gt;[ $stop ]-&gt;{astNodeName}, 
		"&lt;/TH&gt;&lt;/TR&gt;";

	my $col = 0;
	my $colour = "";
	
	for my $ctr ( $start..$stop ) {
		$col = $col ? 0 : 1;
		$colour = $col ? "" : 'bgcolor="#eeeeee"';

		print $file "&lt;TR $colour&gt;&lt;TD&gt;", refNameFull( $list-&gt;[ $ctr ] ),
			"&lt;/TD&gt;&lt;/TR&gt;\n";
	}

	print $file "&lt;/TABLE&gt;";
}


=head2 makeReferences

	Parameters: rootnode

	Recursively traverses the Kids of the root node, setting
	the "Ref" property for each. This is the HTML reference for
	the node. 

	A "NumRef" property is also set for non-compound members,
	which is used for on-page links.

=cut

sub makeReferences
{
	my ( $rootnode ) = @_;

	$rootnode-&gt;{rcount} = 0 ;

	return Iter::Tree ( $rootnode, 1, 
		sub { 					# common
			my ( $root, $node ) = @_;

			$root-&gt;{rcount}++; 
			$node-&gt;AddProp( 'NumRef', "#ref".$root-&gt;{rcount} ); 

			return;
		},
		sub { 					# compound
			my ( $root, $node ) = @_;
			return if defined $node-&gt;{ExtSource};

			if ( $node == $rootnode ) {
				$node-&gt;{Ref} = "all-globals.html";
			}
			else {
				my @heritage = kdocAstUtil::heritage( $node );
				foreach my $n ( @heritage ) { $n = encodeURL( $n );	}
				$node-&gt;{Ref} = join( "__", @heritage ).".html";
			}
			$node-&gt;{rcount} = 0 ;

			return;
		},
		sub {					# member
			my ( $root, $node ) = @_;
			$node-&gt;{Ref} =  $root-&gt;{Ref}."#".encodeURL($node-&gt;{astNodeName})
				unless defined $node-&gt;{ExtSource};

			return;
		}
	);
}

sub makeSourceReferences
{
	my( $rootnode ) = shift;

	return if !exists $rootnode-&gt;{Sources};

	# Set up references

	foreach my $header ( @{$rootnode-&gt;{Sources}} ) {
		my $htmlname = HeaderPathToHTML( $header-&gt;{astNodeName} );
		$header-&gt;{Ref} = $htmlname ;
	}


}


=head2 refName

	Parameters: node, refprop?

	Returns a hyperlinked name of the node if a reference exists,
	or just returns the name otherwise. Useful for printing node names.

	If refprop is specified, it is used as the reference property
	instead of 'Ref'.

=cut

sub refName
{
	my ( $node, $ref ) = @_;
	confess "refName called with undef" unless defined $node-&gt;{astNodeName};

	$ref = 'Ref' unless defined $ref;

	$ref = $node-&gt;{ $ref };

	my $out;

	if ( !defined $ref ) {
		$out =  $node-&gt;{astNodeName};
	} else {
		$out = hyper( $ref, $node-&gt;{astNodeName} );
	}

	$out = "&lt;i&gt;".$out."&lt;/i&gt;" if exists $node-&gt;{Pure};

	return $out;

}

=head2 refNameFull

	Parameters: node, rootnode, refprop?

	Returns a hyperlinked, fully qualified (ie including parents)
	name of the node if a reference exists, or just returns the name
	otherwise. Useful for printing node names.

	If refprop is specified, it is used as the reference property
	instead of 'Ref'.

=cut

sub refNameFull
{
	my ( $node, $rootnode, $refprop ) = @_;

	my $ref = defined $refprop ? $refprop : 'Ref';
	$ref = $node-&gt;{ $ref };
	my $name = join( "::", kdocAstUtil::heritage( $node ) );

	my $out;

	if ( !defined $ref ) {
		$out = $name;
	} else {
		$out = hyper( $ref, $name );
	}

	$out = "&lt;i&gt;".$out."&lt;/i&gt;" if exists $node-&gt;{Pure};

	return $out;
}


=head2 refNameEvery

	Parameters: node

	Like refNameFull, but every separate link in the chain is
	referenced.

=cut

sub refNameEvery
{
	my ( $node, $rootnode ) = @_;



	# make full name
	my $name = $node-&gt;{astNodeName};

	my $parent = $node-&gt;{Parent};

	while ( $parent != $rootnode ) {
		$name = refName($parent)."::".$name;
		$parent = $parent-&gt;{Parent};
	}

	return $name;
}

=head2 hyper

	Parameters: hyperlink, text

	Returns an HTML hyperlink. The text is escaped.

=cut

sub hyper
{
	confess "hyper: undefed parameter $_[0], $_[1]"
		unless defined $_[0] &amp;&amp; defined $_[1];
	return "&lt;A HREF=\"$_[0]\"&gt;".esc($_[1])."&lt;/A&gt;";
}


sub B
{
		my $tag = shift;

		return "&lt;$tag&gt;". join( "", @_). "&lt;/$tag&gt;";
}

=head2 esc

	Escape special HTML characters.

=cut

sub esc
{
	return $_[0] if $allowhtml;

	my $str = $_[0];

	return "" if !defined $str || $str eq "";

#	$str =~ s/([&lt;&gt;&amp;])/$escmap{$1}/g;

#	$str =~ s/&amp;/&amp;amp;/g;
#	$str =~ s/&lt;/&amp;lt;/g;
#	$str =~ s/&gt;/&amp;gt;/g;

	return $str;
}


=head2 printDoc

	Parameters: docnode, *filehandle, rootnode, compound

	Print a doc node. If compound is specified and non-zero, various
	compound node properties are not printed.

=cut

sub printDoc
{
	my $docNode = shift;
	local ( *CLASS, $rootnode ) = @_;
        my ( $comp ) = @_;

        my $type;
	my $lasttype = "none";

	$comp = defined $comp? $comp : 0;

	if ( defined $docNode-&gt;{Main} ) {
		print CLASS "&lt;H2&gt;", 
			deref( $docNode-&gt;{Main}, $rootnode ), "&lt;/H2&gt;\n";
	}

	kdocDocIter::TextIter( $docNode,
		sub { #start
			print CLASS "&lt;p&gt;";
		},
		sub { #end
			print CLASS "&lt;/p&gt;\n";
		},
		sub { #text
			print CLASS "",deref( $_[1], $rootnode );
		},
		sub { #ref
			my ( $node, $name, $ref ) = @_;
			print CLASS defined $ref ? refName( $ref ) : $name;
		},
		sub { #sect
			print CLASS "&lt;/p&gt;\n\n&lt;H3&gt;",
					deref( $_[1], $rootnode),"&lt;/H3&gt;\n&lt;p&gt;\n";
		},
		sub { #pre
			my ( $node, $name, $desc ) = @_;
			$name = textRef( $name, $rootnode );
			$desc = defined $desc ?
				"&lt;tr&gt;&lt;td&gt;&lt;small&gt;$desc&lt;/desc&gt;&lt;/td&gt;&lt;/tr&gt;" : "";

			print CLASS&lt;&lt;EOF;
&lt;/p&gt;&lt;table border="0" width="100%"&gt;
&lt;tr&gt;
&lt;td bgcolor="#BEEAE0"&gt;
&lt;pre&gt;
$name
&lt;/pre&gt;
&lt;/td&gt;&lt;/tr&gt;
$desc
&lt;/table&gt; &lt;p&gt;
EOF
		},
		sub { #image
			print CLASS "&lt;/p&gt;\n&lt;img src=\"", $_[2], "\"&gt;\n&lt;p&gt;\n";		
		},
		sub { #para
			print CLASS "&lt;/p&gt;\n&lt;p&gt;";
		},
		sub { #list start
			print CLASS "&lt;/p&gt;\n\n&lt;ul&gt;\n";
		},
		sub { #list end
			print CLASS "&lt;/ul&gt;\n\n&lt;p&gt;\n";
		},
		sub { #item
			print CLASS "&lt;li&gt;", deref( $_[1], $rootnode ), "&lt;/li&gt;\n";

		}
	);
	
# Params
		kdocDocIter::ParamIter( $docNode,
			sub {
				print CLASS "&lt;p&gt;&lt;b&gt;Parameters&lt;/b&gt;:",
					"&lt;TABLE BORDER=\"0\" CELLPADDING=\"5\"&gt;\n";
			},
			sub {
				print CLASS "&lt;/TABLE&gt;&lt;/P&gt;\n";
			},
			sub {
				my ( $name, $text ) = @_;
				print CLASS "&lt;TR&gt;&lt;TD align=\"left\" valign=\"top\"&gt;&lt;i&gt;",
				$name, "&lt;/i&gt;&lt;/TD&gt;&lt;TD align=\"left\" valign=\"top\"&gt;",
				deref($text, $rootnode ), "&lt;/TD&gt;&lt;/TR&gt;\n";
			}
		);

	# Return
	printTextItem( $docNode, *CLASS, "Returns" );

	# Exceptions
	my $text = $docNode-&gt;{Throws};

	if ( defined $text ) {
		my $comma = "&lt;p&gt;&lt;b&gt;Throws&lt;/b&gt;: ";

		foreach my $tosee ( @$text ) {
			print CLASS $comma, esc( $tosee );
			$comma = ", ";
		}
		print CLASS "&lt;/p&gt;\n";
	}

	# See
	my $comma = "";
	
	kdocDocIter::SeeAlso ( $docNode, undef,
		sub { # start
			print CLASS "&lt;p&gt;&lt;b&gt;See also&lt;/b&gt;: ";
		},
		sub { # print
			my ( $label, $ref ) = @_;
			$label = refName( $ref ) if defined $ref;

			print CLASS $comma, $label;
			$comma = ", ";
		},
		sub { # end
			print CLASS "&lt;/p&gt;\n";
		}
	);
	
	return if $comp;

	printTextItem( $docNode, *CLASS, "Since" );
	printTextItem( $docNode, *CLASS, "Version" );
	printTextItem( $docNode, *CLASS, "Id" );
	printTextItem( $docNode, *CLASS, "Author" );
}

=head2 printTextItem

	Parameters: node, *filehandle, prop, label

	If prop is set, it prints the label and the prop value deref()ed.

=cut

sub printTextItem
{
	my $node = shift;
	local *CLASS = shift;
	my ( $prop, $label ) = @_;

	my $text = $node-&gt;{ $prop };
	
	return unless defined $text;
	$label = $prop unless defined $label;
	
	print CLASS "&lt;p&gt;&lt;b&gt;", $label, "&lt;/b&gt;: ", 
			deref( $text, $rootnode  ), "&lt;/p&gt;\n";
}


=head2 wordRef

	Parameters: word

	Prints a hyperlink to the word's reference if found, otherwise
	just prints the word. Good for @refs etc.

=cut

sub wordRef
{
	my ( $str, $rootnode ) = @_;
	my $out;

	confess "rootnode is undef" if !defined $rootnode;

	return "" if $str eq "";

	my $ref = kdocAstSearch::findRef( $rootnode, $str );

	return esc($str) if !defined $ref;

	if ( defined $ref-&gt;{Ref} ) {
		$out = hyper( $ref-&gt;{Ref}, $str );
	}
	else {
		warn fullName( $ref ). " hasn't a reference.";
		$out = $str;
	}

	return $out;
}

=head2 textRef

	Parameters: string
	Returns: hyperlinked, escaped text.

	Tries to find a reference for EVERY WORD in the string, replacing it
	with a hyperlink where possible. All non-hyper text is escaped.

	Needless to say, this is quite SLOW.

=cut

sub textRef
{
	my ( $str, $rootnode ) = @_;

	$str = esc( $str );
	$str =~ s/([\w:]+)/&amp;wordRef($1,$rootnode)/ge;
	
	return $str;
}

=head2 deref

	Parameters: text
	returns text

	dereferences all @refs in the text and returns it.

=cut

sub deref
{
	my ( $str, $rootnode ) = @_;
	confess "rootnode is null" if !defined $rootnode;
	my $out = "";
	my $text;

# escape @x commands
	foreach $text ( split (/(\@\w+(?:\s+(?:[#\w:~_]+)|\{[^}]+\}))/, $str ) ) {
# check whether $text is an @command or the text between
# @commands
		if (  $text =~ /\@(\w+)(?:\s+([#\w:~_]+)|\s*\{([^}]+)\})/ )   {
			my $command = $1;
			my $content = $2 . $3;

# @ref -- cross reference
			if ( $command eq "ref" ) {
				$content =~ s/\s*#//g;
				$out .= wordRef( $content, $rootnode );
			}

# @p  -- typewriter
			elsif ( $command eq "p" ) {
				$out .= "&lt;code&gt;".esc($content)."&lt;/code&gt;";
			}

# @em -- emphasized
			elsif ( $command eq "em" ) {
				$out .= "&lt;em&gt;".esc($content)."&lt;/em&gt;";
			}

# @sect1-4 -- section header
			elsif ( $command =~ /sect([1-4])$/ ) {
				$out .= "&lt;h$1&gt;".esc($content)."&lt;/h$1&gt;";
			}

# unknown command. warn and copy command
			else {
				warn "Unknown inline tag @", $command, "\n";
				$out .= esc($text);
			}
		}
# no @x command, thus regular text
		else {
			$out .= esc($text);
		}
	}

	return $out;
}

=head2 encodeURL

	Parameters: url

	Returns: encoded URL

=cut

sub encodeURL
{
	my $url = shift;
	my $pfx = "";

	if ( $url =~ /^\s*(\w+:)/ ) {
		$pfx = $1;
		$url =~ s/^$pfx//;
	}

	$url =~ s/([:&lt;&gt; %])/$urlescmap{$1}/g;

	return $pfx.$url;
}

=head2 tabRow

	Returns a table row with each element in the arg list as
	one cell.
	
=cut

sub tabRow
{
	return "&lt;TR&gt;&lt;TH&gt;$_[0]&lt;/TH&gt;&lt;TD&gt;$_[1]&lt;/TD&gt;&lt;/TR&gt;\n";
}

=head2 makeHeader

	Writes an HTML version of a file.

=cut

sub makeHeader
{
	my ( $out, $filename ) = @_;

	open ( SOURCE, "$filename" ) || die "Couldn't read $filename\n";

	print $out "&lt;pre&gt;\n";

	while ( &lt;SOURCE&gt; ) {
		print $out esc( $_ );
	}

	print $out "&lt;/pre&gt;\n";
}

=head2 HeaderPathToHTML

	Takes the path to a header file and returns an html file name.

=cut

sub HeaderPathToHTML
{
	my ( $path ) = @_;

	$path =~ s/_/__/g;
	$path =~ s/\//___/g;
	$path =~ s/\./_/g;
	$path =~ s/:/____/g;

	return $path.".html";
}

# for printing debug node.

sub fullName
{
		return join( "::", kdocAstUtil::heritage( shift ) );
}

1;
</pre></body></html>