add useful tool

src/default.c

@@ -184,9 +184,9 @@ void default_body(FILE* out, const char* top, xl_node_t* element, int spec, int
 		sprintf(tag, "<%s%s>", element->name, text);
 
 		sprintf(end, "</%s>", element->name);
-	} else if(strcmp(element->name, "td") == 0 || /**/
+	} else if(strcmp(element->name, "th") == 0 || /**/
-		  strcmp(element->name, "th") == 0) {
+		  strcmp(element->name, "td") == 0) {
-		accept_attr(top, text, 0, element, "id", "class", "rowspan", "colspan", NULL);
+		accept_attr(top, text, 0, element, "id", "class", "rowspan", "colspan", "width", "height", NULL);
 
 		sprintf(tag, "<%s%s>", element->name, text);
 

tools/docgen.pl

@@ -0,0 +1,44 @@
+#!/usr/bin/env perl
+
+use FindBin;
+use File::Path;
+
+if(@ARGV < 3){
+	print("Usage ./tools/docgen.pl lsp outdir indir ...\n");
+	exit(1);
+}
+
+sub scan {
+	my @args = @_;
+	my $path = $args[0];
+	my $top = $args[1];
+
+	opendir(my $dh, $path);
+
+	my @files = readdir($dh);
+	foreach my $file (@files){
+		if(($file eq ".") || ($file eq "..")){
+			next;
+		}
+
+		if(-d "$path/$file"){
+			scan("$path/$file", $top);
+		}else{
+			print("$path/$file\n");
+
+			my $dir = "$ARGV[1]/$file";
+
+			$dir =~ s/\..*$//;
+
+			mkpath($dir);
+
+			system("$FindBin::Bin/lsp.pl \"$ARGV[0]\" \"$path/$file\" \"$dir/index.xml\" \"$top\"\n");
+		}
+	}
+
+	closedir($dh);
+}
+
+for(my $i = 2; $i < @ARGV; $i += 1){
+	scan($ARGV[$i], $ARGV[$i]);
+}

tools/lib/JSON/backportPP/Boolean.pm

@@ -0,0 +1,44 @@
+package # This is JSON::backportPP
+    JSON::PP::Boolean;
+
+use strict;
+require overload;
+local $^W;
+overload::unimport('overload', qw(0+ ++ -- fallback));
+overload::import('overload',
+    "0+"     => sub { ${$_[0]} },
+    "++"     => sub { $_[0] = ${$_[0]} + 1 },
+    "--"     => sub { $_[0] = ${$_[0]} - 1 },
+    fallback => 1,
+);
+
+$JSON::backportPP::Boolean::VERSION = '4.12';
+
+1;
+
+__END__
+
+=head1 NAME
+
+JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
+
+=head1 SYNOPSIS
+
+ # do not "use" yourself
+
+=head1 DESCRIPTION
+
+This module exists only to provide overload resolution for Storable and similar modules. See
+L<JSON::PP> for more info about this class.
+
+=head1 AUTHOR
+
+This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+

tools/lib/JSON/backportPP/Compat5005.pm

@@ -0,0 +1,131 @@
+package # This is JSON::backportPP
+    JSON::backportPP5005;
+
+use 5.005;
+use strict;
+
+my @properties;
+
+$JSON::PP5005::VERSION = '1.10';
+
+BEGIN {
+
+    sub utf8::is_utf8 {
+        0; # It is considered that UTF8 flag off for Perl 5.005.
+    }
+
+    sub utf8::upgrade {
+    }
+
+    sub utf8::downgrade {
+        1; # must always return true.
+    }
+
+    sub utf8::encode  {
+    }
+
+    sub utf8::decode {
+    }
+
+    *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
+    *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
+    *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
+    *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
+
+    # missing in B module.
+    sub B::SVp_IOK () { 0x01000000; }
+    sub B::SVp_NOK () { 0x02000000; }
+    sub B::SVp_POK () { 0x04000000; }
+
+    $INC{'bytes.pm'} = 1; # dummy
+}
+
+
+
+sub _encode_ascii {
+    join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
+}
+
+
+sub _encode_latin1 {
+    join('', map { chr($_) } unpack('C*', $_[0]) );
+}
+
+
+sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm
+    my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode
+    my $bit = unpack('B32', pack('N', $uni));
+
+    if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) {
+        my ($w, $x, $y, $z) = ($1, $2, $3, $4);
+        return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z));
+    }
+    else {
+        Carp::croak("Invalid surrogate pair");
+    }
+}
+
+
+sub _decode_unicode {
+    my ($u) = @_;
+    my ($utf8bit);
+
+    if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
+         return pack( 'H2', $1 );
+    }
+
+    my $bit = unpack("B*", pack("H*", $u));
+
+    if ( $bit =~ /^00000(.....)(......)$/ ) {
+        $utf8bit = sprintf('110%s10%s', $1, $2);
+    }
+    elsif ( $bit =~ /^(....)(......)(......)$/ ) {
+        $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3);
+    }
+    else {
+        Carp::croak("Invalid escaped unicode");
+    }
+
+    return pack('B*', $utf8bit);
+}
+
+
+sub JSON::PP::incr_text {
+    $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
+
+    if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
+        Carp::croak("incr_text can not be called when the incremental parser already started parsing");
+    }
+
+    $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
+    $_[0]->{_incr_parser}->{incr_text};
+}
+
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005
+
+=head1 DESCRIPTION
+
+JSON::PP calls internally.
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2012 by Makamaka Hannyaharamitu
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
+=cut
+

tools/lib/JSON/backportPP/Compat5006.pm

@@ -0,0 +1,173 @@
+package # This is JSON::backportPP
+    JSON::backportPP56;
+
+use 5.006;
+use strict;
+
+my @properties;
+
+$JSON::PP56::VERSION = '1.08';
+
+BEGIN {
+
+    sub utf8::is_utf8 {
+        my $len =  length $_[0]; # char length
+        {
+            use bytes; #  byte length;
+            return $len != length $_[0]; # if !=, UTF8-flagged on.
+        }
+    }
+
+
+    sub utf8::upgrade {
+        ; # noop;
+    }
+
+
+    sub utf8::downgrade ($;$) {
+        return 1 unless ( utf8::is_utf8( $_[0] ) );
+
+        if ( _is_valid_utf8( $_[0] ) ) {
+            my $downgrade;
+            for my $c ( unpack( "U*", $_[0] ) ) {
+                if ( $c < 256 ) {
+                    $downgrade .= pack("C", $c);
+                }
+                else {
+                    $downgrade .= pack("U", $c);
+                }
+            }
+            $_[0] = $downgrade;
+            return 1;
+        }
+        else {
+            Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
+            0;
+        }
+    }
+
+
+    sub utf8::encode ($) { # UTF8 flag off
+        if ( utf8::is_utf8( $_[0] ) ) {
+            $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
+        }
+        else {
+            $_[0] = pack( "U*", unpack( "C*", $_[0] ) );
+            $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
+        }
+    }
+
+
+    sub utf8::decode ($) { # UTF8 flag on
+        if ( _is_valid_utf8( $_[0] ) ) {
+            utf8::downgrade( $_[0] );
+            $_[0] = pack( "U*", unpack( "U*", $_[0] ) );
+        }
+    }
+
+
+    *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
+    *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
+    *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates;
+    *JSON::PP::JSON_PP_decode_unicode    = \&JSON::PP::_decode_unicode;
+
+    unless ( defined &B::SVp_NOK ) { # missing in B module.
+        eval q{ sub B::SVp_NOK () { 0x02000000; } };
+    }
+
+}
+
+
+
+sub _encode_ascii {
+    join('',
+        map {
+            $_ <= 127 ?
+                chr($_) :
+            $_ <= 65535 ?
+                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
+        } _unpack_emu($_[0])
+    );
+}
+
+
+sub _encode_latin1 {
+    join('',
+        map {
+            $_ <= 255 ?
+                chr($_) :
+            $_ <= 65535 ?
+                sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
+        } _unpack_emu($_[0])
+    );
+}
+
+
+sub _unpack_emu { # for Perl 5.6 unpack warnings
+    return   !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) 
+           : _is_valid_utf8($_[0]) ? unpack('U*', $_[0])
+           : unpack('C*', $_[0]);
+}
+
+
+sub _is_valid_utf8 {
+    my $str = $_[0];
+    my $is_utf8;
+
+    while ($str =~ /(?:
+          (
+             [\x00-\x7F]
+            |[\xC2-\xDF][\x80-\xBF]
+            |[\xE0][\xA0-\xBF][\x80-\xBF]
+            |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
+            |[\xED][\x80-\x9F][\x80-\xBF]
+            |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
+            |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
+            |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
+            |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
+          )
+        | (.)
+    )/xg)
+    {
+        if (defined $1) {
+            $is_utf8 = 1 if (!defined $is_utf8);
+        }
+        else {
+            $is_utf8 = 0 if (!defined $is_utf8);
+            if ($is_utf8) { # eventually, not utf8
+                return;
+            }
+        }
+    }
+
+    return $is_utf8;
+}
+
+
+1;
+__END__
+
+=pod
+
+=head1 NAME
+
+JSON::PP56 - Helper module in using JSON::PP in Perl 5.6
+
+=head1 DESCRIPTION
+
+JSON::PP calls internally.
+
+=head1 AUTHOR
+
+Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2007-2012 by Makamaka Hannyaharamitu
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself. 
+
+=cut
+

tools/lsp.pl

@@ -0,0 +1,322 @@
+#!/usr/bin/env perl
+# Does this script even work under Windows?
+
+use FindBin;
+
+use lib "$FindBin::Bin/lib";
+
+use FileHandle;
+use IPC::Open3;
+use JSON;
+use Cwd;
+
+my $incr = 1;
+
+sub notify {
+	my @args = @_;
+	my $hash = {
+		jsonrpc => "2.0",
+		method => $args[0],
+		params => $args[1]
+	};
+	my $json = JSON->new();
+	my $str = $json->encode($hash);
+	my $len = 0;
+
+	print(Writer "Content-Length: " . length($str) . "\r\n");
+	print(Writer "\r\n");
+	print(Writer $str);
+}
+
+sub request {
+	my @args = @_;
+	my $hash = {
+		jsonrpc => "2.0",
+		id => $incr,
+		method => $args[0],
+		params => $args[1]
+	};
+	my $json = JSON->new();
+	my $str = $json->encode($hash);
+	my $len = 0;
+
+	print(Writer "Content-Length: " . length($str) . "\r\n");
+	print(Writer "\r\n");
+	print(Writer $str);
+
+	do {
+		while(my $l = <Reader>){
+			$l =~ s/\r?\n$//;
+
+			if(length($l) == 0){
+				last;
+			}else{
+				$l =~ /^(.+?):[ ]*(.*?)$/;
+
+				if(lc($1) eq "content-length"){
+					$len = +$2;
+				}
+			}
+		}
+
+		read Reader, $str, $len;
+		$hash = $json->decode($str);
+	}while($hash->{id} != $incr);
+
+	$incr += 1;
+
+	return $hash;
+}
+
+if(@ARGV < 3){
+	print(STDERR "Usage: ./tools/lsp.pl lsp input output [strip_path...]\n");
+	exit(1);
+}
+
+my $pid = open3(\*Writer, \*Reader, \*Error, $ARGV[0]);
+Writer->autoflush();
+
+request("initialize", {
+	rootUri => undef,
+	capabilities => {
+		textDocument => {
+			documentSymbol => {
+				symbolKind => {
+					valueSet => [
+						12
+					]
+				},
+				hierarchicalDocumentSymbolSupport => JSON::true,
+				labelSupport => JSON::true
+			},
+			hover => {
+				contentFormat => [
+					"plaintext"
+				]
+			}
+		}
+	}
+});
+
+$ARGV[1] =~ /\.(.*)$/;
+
+my $ext = $1;
+my $exts = {
+	h => "c",
+	c => "c",
+	cpp => "cpp",
+	hpp => "cpp"
+};
+
+open(IN, $ARGV[1]);
+my $data = do {local $/; <IN>};
+close(IN);
+
+open(IN, $ARGV[1]);
+my @lines = <IN>;
+close(IN);
+
+my $uri = "file://" . Cwd::abs_path($ARGV[1]);
+
+notify("textDocument/didOpen", {
+	textDocument => {
+		uri => $uri,
+		languageId => $exts->{$ext},
+		version => 1,
+		text => $data
+	}
+});
+
+sub markdown {
+	my @args = @_;
+	my $str = escape($args[0]);
+
+	$str =~ s/\*\*\*(.*)\*\*\*/<b><i>\1<\/i><\/b>/g;
+	$str =~ s/\*\*(.*)\*\*/<b>\1<\/b>/g;
+	$str =~ s/\*(.*)\*/<i>\1<\/i>/g;
+	$str =~ s/`(.*)`/<code>\1<\/code>/g;
+
+	if(!(substr($str, length($str) - 1, 1) eq ".")){
+		$str = $str . ".";
+	}
+
+	return $str;
+}
+
+sub get_line {
+	my @args = @_;
+	my $range = $args[0];
+
+	return substr($lines[$range->{start}->{line}], $range->{start}->{character}, $range->{end}->{character} - $range->{start}->{character});
+}
+
+sub escape {
+	my @args = @_;
+	my $str = $args[0];
+
+	$str =~ s/&/&amp;/g;
+	$str =~ s/</&lt;/g;
+	$str =~ s/>/&gt;/g;
+
+	return $str;
+}
+
+sub directive {
+	my @args = @_;
+	my $dir = $args[0];
+
+	$dir =~ /^([^ ]+?)(?: +(.*))?$/;
+
+	return ($1, $2);
+}
+
+sub recursive {
+	my @args = @_;
+	my $arr = $args[0];
+
+	foreach my $symbol (@$arr){
+		if($symbol->{kind} == 3){
+			recursive($symbol->{children});
+		}elsif($symbol->{kind} == 12){
+			my $json = request("textDocument/hover", {
+				textDocument => {
+					uri => $uri
+				},
+				position => $symbol->{selectionRange}->{start}
+			});
+
+			if($json->{result} && $json->{result}->{contents}->{value}){
+				my $l = $json->{result}->{contents}->{value};
+
+				$l =~ s/\r?\n/\n/g;
+				$l =~ s/^[^@].*\n//gm;
+
+				my @dirs = split(/\n/, $l);
+
+				my $c = $l;
+
+				$c =~ s/^/    /gm;
+
+				my $t = 0;
+				foreach my $dir (@dirs){
+					my ($key, $val) = directive($dir);
+
+					if($key eq "\@param"){
+						$t += 1;
+					}
+				}
+
+				print(OUT "		<section title=\"$symbol->{name}\">\n");
+
+				foreach my $dir (@dirs){
+					my ($key, $val) = directive($dir);
+
+					if($key eq "\@brief"){
+						print(OUT "			<p>\n");
+						print(OUT "				" . markdown($val) . "\n");
+						print(OUT "			</p>\n");
+					}
+				}
+
+				print(OUT "			<table>\n");
+				print(OUT "				<tr>\n");
+				print(OUT "					<th width=\"100\">\n");
+				print(OUT "						Definition\n");
+				print(OUT "					</th>\n");
+				print(OUT "					<td colspan=\"2\">\n");
+				print(OUT "						<code>" . escape(get_line($symbol->{range})) . "</code>\n");
+				print(OUT "					</td>\n");
+				print(OUT "				</tr>\n");
+
+				$c = 0;
+				foreach my $dir (@dirs){
+					my ($key, $val) = directive($dir);
+
+					if($key eq "\@param"){
+						($key, $val) = directive($val);
+
+						print(OUT "				<tr>\n");
+						if($c == 0){
+							print(OUT "					<th width=\"100\" rowspan=\"$t\">\n");
+							print(OUT "						Parameters\n");
+							print(OUT "					</th>\n");
+						}
+						print(OUT "					<th>\n");
+						print(OUT "						$key\n");
+						print(OUT "					</th>\n");
+						print(OUT "					<td width=\"70%\">\n");
+						print(OUT "						" . markdown($val) . "\n");
+						print(OUT "					</td>\n");
+						print(OUT "				</tr>\n");
+
+						$c += 1;
+					}
+				}
+
+				foreach my $dir (@dirs){
+					my ($key, $val) = directive($dir);
+
+					if($key eq "\@return"){
+						print(OUT "				<tr>\n");
+						print(OUT "					<th width=\"100\">\n");
+						print(OUT "						Return\n");
+						print(OUT "					</th>\n");
+						print(OUT "					<td colspan=\"2\">\n");
+						print(OUT "						" . markdown($val) . "\n");
+						print(OUT "					</td>\n");
+						print(OUT "				</tr>\n");
+
+						$c += 1;
+					}
+				}
+
+				print(OUT "			</table>\n");
+
+				foreach my $dir (@dirs){
+					my ($key, $val) = directive($dir);
+
+					if(($key eq "\@warning") || ($key eq "\@note")){
+						$key = substr($key, 1);
+
+						print(OUT "			<$key>\n");
+						print(OUT "				" . markdown($val) . "\n");
+						print(OUT "			</$key>\n");
+					}
+				}
+
+				print(OUT "		</section>\n");
+			}
+		}
+	}
+}
+
+my $json = request("textDocument/documentSymbol", {
+	textDocument => {
+		uri => $uri
+	}
+});
+
+my $input = $ARGV[1];
+
+for(my $i = 3; $i < @ARGV; $i += 1){
+	$input =~ s/^\Q$ARGV[$i]\E\/?//;
+}
+
+open(OUT, ">", $ARGV[2]);
+print(OUT "<?xml version=\"1.0\"?>\n");
+print(OUT "<document>\n");
+print(OUT "	<header>\n");
+print(OUT "		<title>Documentation of $input</title>\n");
+print(OUT "	</header>\n");
+print(OUT "	<body>\n");
+
+recursive($json->{result});
+
+print(OUT "	</body>\n");
+print(OUT "</document>\n");
+close(OUT);
+
+close(Reader);
+close(Writer);
+close(Error);
+waitpid($pid, 0);