source: ThirdParty/mpqc_open/bin/class2tex@ 860145

#!/usr/bin/perl
# Use -*-perl-*- mode in emacs.

@files = ();

$clssection = "section";
$clssubsection = "subsection";

#for $i (@ARGV) {
while ($i = shift) {
    if ($i eq '-clssection') {
        $clssection = shift;
    }
    elsif ($i eq '-clssubsection') {
        $clssubsection = shift;
    }
    else {
        @files = (@files, $i);
    }
}
@ARGV = @files;

$printmember = 0;
$printmembercase = 0;
$template_param = '';
$class = '';
$classdoc = '';
%item = ();
%sectionname = (pri, "Private", pro, "Protected", pub, "Public");
@sectionorder = (pub, pro, pri);
while(<>) {

    while(/^\s*\/\//) {
        if (/^\s*\/\/\.\s+(.*)/) {
            do get_doc($1);
        }
        elsif (/^\s*\/\/\.\s*$/) {
            do get_doc('');
        }
        else {
            last;
        }
    }

    if (/^\s*class\s+([a-zA-Z_][a-zA-Z0-9_]*)/) {
        do new_class($1,'','');
    }
    elsif (/^\s*template <(.*)>\s*class\s+([a-zA-Z_][a-zA-Z0-9_]*)/) {
        do new_class($2,$1,'');
    }
    elsif (/^\s*template <(.*)>\s*$/) {
        $tmp_template_param = $1;
        while (<>) { last; }
        if (/^\s*class\s+([a-zA-Z_][a-zA-Z0-9_]*)/) {
            do new_class($1,$tmp_template_param,'');
        }
    }
    elsif (/^\s*private\s*:/) {
        $interface = 'pri';
    }
    elsif (/^\s*public\s*:/) {
        $interface = 'pub';
    }
    elsif (/^\s*protected\s*:/) {
        $interface = 'pro';
    }
}

do write_doc();

sub new_class {
    # flush out the documentation for the previous class
    do write_doc();
    $class = $_[0];
    $template_param = $_[1];
    $classdoc = $_[2];
    $interface = 'pri';
    $private = '';
    $protected = '';
    $public = '';
}

sub write_doc {
    local($nsection) = keys(%item);
    if ($classdoc ne ''
        || $item{'pri'} ne ''
        || $item{'pro'} ne ''
        || $item{'pub'} ne '') {
        $template_param =~ s/_/\\_/g;
        if (!open(OUTPUT, ">doc/$class.cls.tex")) {
            die "Can't open doc/$class.cls.tex: $!";
        }
        print "writing $class.cls.tex\n";
        if ($template_param eq '') {
            print OUTPUT "\\$clssection\{The \\clsnm{$class} Class}";
            print OUTPUT "\\label{$class}\\index{$class}\n";
            #print OUTPUT "\\clssection{$class}\n";
        }
        else {
            print OUTPUT "\\$clssection\{The \\clsnm{$class";
            print OUTPUT "\$<\$$template_param\$>\$} Class Template}";
            print OUTPUT "\\label{$class}\\index{$class}\n";
            #print OUTPUT "\\tclssection{$class}{$template_param}\n";
        }
        print OUTPUT "\\index{$class}\n";
        if ($classdoc ne '') {
            print OUTPUT "$classdoc\n";
        }
        for (@sectionorder) {
            if ($item{$_} ne '') {
                if ($template_param eq '') {
                    print OUTPUT "\\$clssubsection\{The $sectionname{$_} \\clsnm{$class} Interface}\n";
                }
                else {
                    print OUTPUT "\\$clssubsection\{The \\clsnm{$class";
                    print OUTPUT "\$<\$$template_param\$>\$} Class Template Interface}\n";
                }
                local($memberdoc) = $item{$_};
                # two items in a row shouldn't have an mbox
                $memberdoc =~ s/\\mbox{}\\\\\s*\\item\[/\n\\item\[/g;
                print OUTPUT "\\begin{classinterface}\n";
                print OUTPUT $memberdoc;
                print OUTPUT "\\end{classinterface}\n";
            }
        }
        close(OUTPUT);
    }
    %item = ();
    $classdoc = '';
}

sub beautify_member {
    $m = $_[0];

    print "MEM=$m\n" if ($printmember);

    $_ = $m;

    # remove inline
    s/inline//;

    # remove parent/member constructor calls
    s/::/SAVEDCOLONCOLON/g;
    s/:.*$//;
    s/SAVEDCOLONCOLON/::/g;

    $virtual = 0;
    $static = 0;
    $constreturn = 0;
    # check for a constructor
    if (/^\s*[A-Za-z_][A-Za-z0-9_]*\s*\(/) {
        $typename = 'void';
    }
    # check for a destructor
    elsif (/^\s*(virtual\s)?\s*~\s*[A-Za-z_][A-Za-z0-9_]*\s*\(/) {
        $typename = 'void';
        if (s/^\s*virtual//) { $virtual = 1; }
    }
    else {
        # parse the virtual and static qualifiers
        if (s/^\s*virtual//) {
            $virtual = 1;
        }
        elsif (s/^\s*static//) {
            $static = 1;
        }

        # parse the const qualifier
        if (s/^\s*const//) {
            $constreturn = 1;
        }

        # parse the type name
        /^\s*([A-Za-z_][A-Za-z_0-9<>,]*)(.*)/;
        $typename = $1;
        $_ = $2;

        # parse the reference and pointer and const qualifiers
        while (/^\s*(&)(.*)/ || /^\s*(\*)(.*)/ || /^\s*(const)(.*)/) {
            $typename = "$typename $1";
            $_ = $2;
        }

        $typename =~ s/&/\\&/g;
        $typename =~ s/_/\\_/g;
        $typename =~ s/</\$<\$/g;
        $typename =~ s/>/\$>\$/g;
        $typename = "const $typename" if ($constreturn);
    }

    # parse the member name
    ($destructor, $membername, $rest) =
        /^\s*(~?)\s*([A-Za-z_][A-Za-z0-9_]*)(.*)/;
    $_ = $rest;
    $membername = "$destructor$membername";
    if ($typename eq "operator") {
        # fixup type conversion operators
        $typename = "$membername";
        $membername = "operator $membername";
    }
    elsif ($membername eq 'operator') {
        # operator () is a special case
        if (/^\s*\(\s*\)(.*)/) {
            $membername = "$membername ()";
            $_ = $1;
        }
        else {
            /^\s*([^(]*)\s*(\(.*)/;
            $membername = "$membername $1";
            $_ = $2;
        }
    }
    #print "MN = $membername, _ = $_\n";

    # look for underscores in membername
    #@membername = split(/_/,$membername);
    #$item = "";
    #foreach $i (0 .. $#membername) {
    #    $item = join('$item',"{\\bfseries $membername[$i]}");
    #    if ($i != $#membername) {
    #        $item = "$item\_";
    #    }
    #}
    $item = "{\\bfseries $membername}";
    $item =~ s/_/\\_/g;

    # take care of special characters in item
    $item =~ s/&/\\&/g;
    $item =~ s/</\$<\$/g;
    $item =~ s/>/\$>\$/g;
    $item =~ s/~/\$\\tilde{}\$/;

    # parse the arglist
    /\((.*)\)(.*)/;
    $arglist = $1;
    $_ = $2;

    # take care of special characters in arglist
    $arglist =~ s/&/\\&/g;
    $arglist =~ s/</\$<\$/g;
    $arglist =~ s/>/\$>\$/g;
    $arglist =~ s/_/\\_/g;

    # make sure there is whitespace after commas (for better formatting).
    $arglist =~ s/,\s*/, /g;

    # parse the constness of calling object
    $constobject = 0;
    if (/^[ \t]*const(.*)/) {
        $constobject = 1;
        $_ = $1;
    }

    # parse the pure virtual qualifier
    $pure = 0;
    if (/[ \t]*=[ \t]*0(.*)/) {
        $pure = 1;
        $_ = $1;
    }

    # construct the table entry

    $qualifiers = '';
    if ($constobject) {
        $qualifiers = "$qualifiers const";
    }
    if ($pure) {
        $qualifiers = "$qualifiers pure";
    }
    elsif ($virtual) {
        $qualifiers = "$qualifiers virtual";
    }
    elsif ($static) {
        $qualifiers = "$qualifiers static";
    }
    $_ = $qualifiers;
    /[ \t]*(.*)[ \t]*/;
    $qualifiers = $1;

    #$item = "\@b{$membername}($arglist)";
    $item = "$item($arglist)";
    if ($qualifiers ne '') {
        $item = "$item $qualifiers";
    }
    if ($typename ne 'void') {
        $item = "$item \$\\rightarrow\$ {\\bfseries $typename}";
    }

    return "$item";
}

sub get_doc {
    $doc = $_[0];
    $members = '';
    $indoc = 1;
    while (<>) {
        if ($indoc && /^\s*\/\/(\.)?(\s*.*)/) {
            $doc = "$doc\n$2";
        }
        elsif (/^\s*template <(.*)>\s*class\s+([a-zA-Z_][a-zA-Z0-9_]*)/) {
            do new_class($2,$1,'');
        }
        elsif (/^\s*template <(.*)>\s*$/) {
            $tmp_template_param = $1;
            while (<>) { last; }
            if (/^\s*class\s+([a-zA-Z_][a-zA-Z0-9_]*)/) {
                while(<>) { last; }
                do new_class($1,$tmp_template_param,'');
                last;
            }
        }
        elsif (/^\s*class\s+([a-zA-Z_][a-zA-Z0-9_]*)/) {
            while(<>) { last; }
            do new_class($1,'',$doc);
            last;
        }
        elsif (/^\s*((~\s*)?[A-Za-z_].*,)\s*$/) {
            $indoc = 0;
            $member = $1;
            $remainder = &read_member_continuation;
            $member = "$member$remainder";
            print "CASE 1: MEM=$member\n" if ($printmembercase);
            $member = &beautify_member($member);
            $members = "$members\\item[$member]\\mbox{}\\\\\n";
        }
        elsif (/^\s*((~\s*)?[A-Za-z_].*)\s*{/) {
            $indoc = 0;
            print "CASE 2: MEM=$1\n" if ($printmembercase);
            $member = &beautify_member($1);
            $members = "$members\\item[$member]\\mbox{}\\\\\n";
            # attempt to skip over simple routines
            &skip_inlined_routine("{$'");
        }
        elsif (/^\s*((~\s*)?[A-Za-z_].*);\s*/) {
            $indoc = 0;
            print "CASE 3: MEM=$1\n" if ($printmembercase);
            $member = &beautify_member($1);
            $members = "$members\\item[$member]\\mbox{}\\\\\n";
        }
        elsif (/^\s*((~\s*)?[A-Za-z_].*)\s*/) {
            $indoc = 0;
            $member = $1;
            if (! /\)/) {
                # the member is not complete--finish it
                $remainder = &read_member_continuation;
                $member = "$member$remainder";
            }
            print "CASE 4: MEM=$member\n" if ($printmembercase);
            $member = &beautify_member($member);
            $members = "$members\\item[$member]\\mbox{}\\\\\n";
        }
        elsif (/^\s*{/) {
            $indoc = 0;
            &skip_inlined_routine("{$'");
        }
        else {
            $item{$interface} = "$item{$interface}$members$doc\n\n";
            last;
        }
    }
}

sub skip_inlined_routine {
    local($_) = $_[0];
    local($nbracket) = &count_brackets($_);
    return if ($nbracket == 0);
    while (<>) {
        $nbracket = $nbracket + &count_brackets($_);
        return if ($nbracket == 0);
    }
}

sub count_brackets {
    local($_) = $_[0];
    local($n) = 0;
    s/"[^\"]*"//g;
    local(@chars) = split(//,$_);
    foreach (@chars) {
        if ($_ eq "{") {
            $n++;
        }
        elsif ($_ eq "}") {
            $n--;
        }
    }
    return $n;
}

sub read_member_continuation {
    local($member) = "";
    while (<>) {
        if (/^\s*(.*,)\s*$/) {
            $member = "$member$1";
        }
        elsif (/^\s*(.*){\s*/) {
            $member = "$member$1";
            # attempt to skip over simple routines
            &skip_inlined_routine("{$'");
            last;
        }
        elsif (/^\s*(.*);\s*/) {
            $member = "$member$1";
            last;
        }
        elsif (/};/) {
            last;
        }
        else {
            printf "BAD MEMBER CONTINUATION: $_\n";
        }
    }
    return $member;
}