386 lines
9.3 KiB
Perl
Executable File
386 lines
9.3 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
# make-doc.pl
|
|
# WSLUA's Reference Manual Generator
|
|
#
|
|
# (c) 2006, Luis E. Garcia Onatnon <luis.ontanon@gmail.com>
|
|
#
|
|
# $Id$
|
|
#
|
|
# Wireshark - Network traffic analyzer
|
|
# By Gerald Combs <gerald@wireshark.org>
|
|
# Copyright 1998 Gerald Combs
|
|
#
|
|
# This program is free software; you can redistribute it and/or
|
|
# modify it under the terms of the GNU General Public License
|
|
# as published by the Free Software Foundation; either version 2
|
|
# of the License, or (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
# GNU General Public License for more details.
|
|
#
|
|
# You should have received a copy of the GNU General Public License
|
|
# along with this program; if not, write to the Free Software
|
|
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
|
|
#
|
|
# (-: I don't even think writing this in Lua :-)
|
|
|
|
use strict;
|
|
#use V2P;
|
|
|
|
sub deb {
|
|
# warn $_[0];
|
|
}
|
|
|
|
sub gorolla {
|
|
# a gorilla stays to a chimp like ... stays to chomp
|
|
# but this one returns the shrugged string.
|
|
my $s = shift;
|
|
$s =~ s/^([\n]|\s)*//ms;
|
|
$s =~ s/([\n]|\s)*$//ms;
|
|
$s;
|
|
}
|
|
|
|
my $class;
|
|
my %classes;
|
|
my $function;
|
|
my @functions;
|
|
|
|
my %template = %{{
|
|
class_header => "= %s =\n",
|
|
class_desc => "%s\n",
|
|
class_constructors_header => "== %s constructors ==\n",
|
|
class_methods_header => "== %s methods ==\n",
|
|
class_attributes_header => "== %s Attributes ==\n",
|
|
class_attr_header => "=== %s ===\n",
|
|
class_attr_descr => "%s\n",
|
|
function_header => "=== %s ===\n",
|
|
function_descr => "%s\n",
|
|
function_arg_header => "==== %s ====\n",
|
|
function_arg_descr => "%s\n",
|
|
function_argerrors_header => "'''Errors:'''\n",
|
|
function_argerror => " * %s\n",
|
|
function_returns_header => "==== returns ====\n",
|
|
function_returns => " * %s\n",
|
|
function_errors_header => "==== errors ====\n",
|
|
function_errors => " * %s\n",
|
|
non_method_functions_header => "= Non method functions =\n",
|
|
}};
|
|
|
|
|
|
my %metamethods = %{{
|
|
__tostring => "tostring(__)",
|
|
__index => "__[]",
|
|
__newindex => "__[] = ",
|
|
__add => "__ + __",
|
|
__sub => "__ - __",
|
|
__mul => "__ * __",
|
|
__div => "__ / __",
|
|
__mod => "__ % __",
|
|
__pow => "__ ^ __",
|
|
__unm => "-___",
|
|
__concat => "__ .. __",
|
|
__len => "#__",
|
|
__call => "()",
|
|
__eq => "__ == __",
|
|
__lt => "__ < __",
|
|
__le => "__ <= __",
|
|
}};
|
|
|
|
# It's said that only perl can parse perl... my editor isn't perl...
|
|
# if unencoded this causes my editor's autoindent to bail out so I encoded in octal
|
|
# XXX: support \" within ""
|
|
my $QUOTED_RE = "\042\050\133^\042\135*\051\042";
|
|
|
|
my $TRAILING_COMMENT_RE = '((\s*|[\n\r]*)/\*(.*?)\*/)?';
|
|
|
|
my @control =
|
|
(
|
|
# This will be scanned in order trying to match the re if it matches
|
|
# the body will be executed immediatelly after.
|
|
|
|
[ 'WSLUA_CLASS_DEFINE\050\s*([A-Z][a-zA-Z]+)\s*,.*?\051' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">c=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
$class = {
|
|
name => $1,
|
|
descr=> gorolla($4),
|
|
constructors => [],
|
|
methods => [],
|
|
metamethods => [],
|
|
attributes => []
|
|
};
|
|
$classes{$1} = $class;
|
|
}],
|
|
|
|
[ 'WSLUA_FUNCTION\s+wslua_([a-z_]+)[^\173]*\173' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">f=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
$function = {
|
|
returns => [],
|
|
arglist => [],
|
|
args => {},
|
|
name => $1,
|
|
descr => gorolla($4),
|
|
type => 'standalone'
|
|
};
|
|
push @functions, $function;
|
|
} ] ,
|
|
|
|
[ 'WSLUA_CONSTRUCTOR\s+([A-Za-z]+)_([a-z_]+).*?\173' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">cc=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
$function = {
|
|
returns => [],
|
|
arglist => [],
|
|
args => {},
|
|
name => "$1.$2",
|
|
descr => gorolla($5),
|
|
type => 'constructor'
|
|
};
|
|
push @{${$class}{constructors}}, $function;
|
|
} ] ,
|
|
|
|
[ 'WSLUA_METHOD\s+([A-Za-z]+)_([a-z_]+)[^\173]*\173' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">cm=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
$function = {
|
|
returns => [],
|
|
arglist => [],
|
|
args => {},
|
|
name => "$1:$2",
|
|
descr => gorolla($5),
|
|
type => 'method'
|
|
};
|
|
push @{${$class}{methods}}, $function;
|
|
} ] ,
|
|
|
|
[ 'WSLUA_METAMETHOD\s+([A-Za-z]+)(__[a-z]+)[^\173]*\173' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">cm=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
my $name = $metamethods{$2};
|
|
my ($c,$d) = ($1,$5);
|
|
$name =~ s/__/$c/g;
|
|
$function = {
|
|
returns => [],
|
|
arglist => [],
|
|
args => {},
|
|
name => $name,
|
|
descr => gorolla($d),
|
|
type => 'metamethod'
|
|
};
|
|
push @{${$class}{metamethods}}, $function;
|
|
} ] ,
|
|
|
|
[ '#define WSLUA_(OPT)?ARG_([a-z_]+)_([A-Z0-9]+)\s+\d+' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">a=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
push @{${$function}{arglist}} , $3;
|
|
${${$function}{args}}{$3} = {descr=>$6}
|
|
} ],
|
|
|
|
[ '#define WSLUA_(OPT)?ARG_([A-Za-z]+)_([a-z_]+)_([A-Z0-9]+)\s+\d+' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">ca=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
push @{${$function}{arglist}} , $4;
|
|
${${$function}{args}}{$4} = {descr=>$7}
|
|
} ],
|
|
|
|
[ '/\052\s+WSLUA_ATTRIBUTE\s+([A-Za-z]+)_([a-z_]+)\s+([A-Z]*)\s*(.*?)\052/',
|
|
sub {
|
|
deb ">at=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
push @{${$class}{attributes}}, { name => $2, descr => gorolla($4), mode=>$3 };
|
|
} ],
|
|
|
|
[ '/\052\s+WSLUA_MOREARGS\s+([A-Za-z_]+)\s+(.*?)\052/',
|
|
sub {
|
|
deb ">ma=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
push @{${$function}{arglist}} , "...";
|
|
${${$function}{args}}{"..."} = {descr=>gorolla($2)}
|
|
} ],
|
|
|
|
[ 'WSLUA_(FINAL_)?RETURN\050\s*.*?\s*\051\s*;' . $TRAILING_COMMENT_RE,
|
|
sub {
|
|
deb ">fr=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
push @{${$function}{returns}} , gorolla($4) if $4 ne '';
|
|
} ],
|
|
|
|
[ 'WSLUA_ERROR\s*\050\s*(([A-Z][A-Za-z]+)_)?([a-z_]+),' . $QUOTED_RE ,
|
|
sub {
|
|
deb ">e=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
my $errors;
|
|
unless (exists ${$function}{errors}) {
|
|
$errors = ${$function}{errors} = [];
|
|
} else {
|
|
$errors = ${$function}{errors};
|
|
}
|
|
|
|
push @{$errors}, gorolla($4);
|
|
} ],
|
|
|
|
[ 'WSLUA_(OPT)?ARG_ERROR\s*\050\s*(([A-Z][A-Za-z]+)_)?([a-z_]+)\s*,\s*([A-Z0-9]+)\s*,\s*' . $QUOTED_RE,
|
|
sub {
|
|
deb ">ae=$1=$2=$3=$4=$5=$6=$7=\n";
|
|
my $errors;
|
|
unless (exists ${${${$function}{args}}{$5}}{errors}) {
|
|
$errors = ${${${$function}{args}}{$5}}{errors} = [];
|
|
} else {
|
|
$errors = ${${${$function}{args}}{$5}}{errors};
|
|
}
|
|
|
|
push @{$errors}, gorolla($6);
|
|
} ] ,
|
|
);
|
|
|
|
my $anymatch = '(^ThIsWiLlNeVeRmAtCh$';
|
|
for (@control) {
|
|
$anymatch .= "|${$_}[0]";
|
|
}
|
|
$anymatch .= ')';
|
|
|
|
# for each file given in the command line args
|
|
my $file;
|
|
while ( $file = shift) {
|
|
|
|
next unless -f $file;
|
|
|
|
my $docfile = $file;
|
|
$docfile =~ s/\.c$/.pod/;
|
|
|
|
open C, "< $file";
|
|
open D, "> doc/$docfile";
|
|
|
|
my $b = '';
|
|
$b .= $_ while (<C>);
|
|
|
|
while ($b =~ /$anymatch/ms ) {
|
|
my $match = $1;
|
|
# print "\n-----\n$match\n-----\n";
|
|
for (@control) {
|
|
my ($re,$f) = @{$_};
|
|
if ( $match =~ /$re/ms) {
|
|
&{$f}();
|
|
$b =~ s/.*?$re//ms;
|
|
last;
|
|
}
|
|
}
|
|
}
|
|
|
|
for my $cname (sort keys %classes) {
|
|
my $cl = $classes{$cname};
|
|
printf D $template{class_header}, $cname;
|
|
printf D $template{class_desc} , ${$cl}{descr} if ${$cl}{descr};
|
|
|
|
if ( $#{${$cl}{constructors}} >= 0) {
|
|
printf D $template{class_constructors_header}, $cname;
|
|
|
|
for my $c (@{${$cl}{constructors}}) {
|
|
function_descr($c);
|
|
}
|
|
|
|
printf D $template{class_constructors_footer}, $cname;
|
|
}
|
|
|
|
if ( $#{${$cl}{methods}} >= 0) {
|
|
printf D $template{class_methods_header}, $cname;
|
|
|
|
for my $m (@{${$cl}{methods}}) {
|
|
function_descr($m);
|
|
}
|
|
|
|
printf D $template{class_methods_footer}, $cname;
|
|
}
|
|
|
|
if ( $#{${$cl}{metamethods}} >= 0) {
|
|
printf D $template{class_metamethods_header}, $cname;
|
|
|
|
for my $m (@{${$cl}{metamethods}}) {
|
|
function_descr($m,${$m}{name});
|
|
}
|
|
|
|
printf D $template{class_metamethods_footer}, $cname;
|
|
}
|
|
|
|
if ( $#{${$cl}{attributes}} >= 0) {
|
|
printf D $template{class_attributes_header}, $cname;
|
|
|
|
for my $a (@{${$cl}{attributes}}) {
|
|
printf D $template{class_attr_header}, ${$a}{name};
|
|
printf D $template{class_attr_descr}, ${$a}{descr} if ${$a}{descr};
|
|
printf D $template{class_attr_footer}, ${$a}{name};
|
|
|
|
}
|
|
|
|
printf D $template{class_attributes_footer}, $cname;
|
|
}
|
|
}
|
|
|
|
if ($#functions >= 0) {
|
|
print D $template{non_method_functions_header};
|
|
|
|
for my $f (@functions) {
|
|
function_descr($f);
|
|
}
|
|
}
|
|
|
|
%classes = ();
|
|
$class = undef;
|
|
$function = undef;
|
|
@functions = ();
|
|
close C;
|
|
close D;
|
|
}
|
|
|
|
sub function_descr {
|
|
my $f = $_[0];
|
|
my $label = $_[1];
|
|
|
|
if (defined $label ) {
|
|
printf D $template{function_header}, $label;
|
|
} else {
|
|
my $arglist = '';
|
|
|
|
for (@{ ${$f}{arglist} }) {
|
|
my $a = $_;
|
|
$a =~ tr/A-Z/a-z/;
|
|
$arglist .= "$a, ";
|
|
}
|
|
|
|
$arglist =~ s/, $//;
|
|
|
|
printf D $template{function_header}, "${$f}{name}($arglist)";
|
|
}
|
|
|
|
printf D $template{function_descr}, ${$f}{descr} if ${$f}{descr};
|
|
|
|
for my $argname (@{${$f}{arglist}}) {
|
|
my $arg = ${${$f}{args}}{$argname};
|
|
$argname =~ tr/A-Z/a-z/;
|
|
|
|
printf D $template{function_arg_header}, $argname;
|
|
printf D $template{function_arg_descr}, ${$arg}{descr} if ${$arg}{descr};
|
|
|
|
if ( $#{${$arg}{errors}} >= 0) {
|
|
printf D $template{function_argerrors_header}, $argname;
|
|
printf D $template{function_argerror}, $_ for @{${$arg}{errors}};
|
|
printf D $template{function_argerrors_footer}, $argname;
|
|
}
|
|
|
|
}
|
|
|
|
if ( $#{${$f}{returns}} >= 0) {
|
|
printf D $template{function_returns_header}, ${$f}{name};
|
|
printf D $template{function_returns}, $_ for @{${$f}{returns}};
|
|
printf D $template{function_returns_footer}, ${$f}{name};
|
|
}
|
|
|
|
if ( $#{${$f}{errors}} >= 0) {
|
|
printf D $template{function_errors_header}, ${$f}{name};
|
|
printf D $template{function_errors}, $_ for @{${$f}{errors}};
|
|
printf D $template{function_errors_footer}, ${$f}{name};
|
|
}
|
|
|
|
}
|