# =======================================================================
# Doxygen Pre-Processor for Perl
# Copyright (C) 2002  Bart Schuller
# Copyright (C) 2006  Phinex Informatik AG
# All Rights Reserved
#
# Doxygen Filter is free software; you can redistribute it and/or modify
# it under the same terms as Perl itself.
#
# Larry Wall's 'Artistic License' for perl can be found in
# http://www.perl.com/pub/a/language/misc/Artistic.html
#
# =======================================================================
#
# Author: Aeby Thomas, Phinex Informatik AG,
#           Based on DoxygenFilter from Bart Schuller
# E-Mail: tom.aeby@phinex.ch
#
# Phinex Informatik AG
# Thomas Aeby
# Kirchweg 52
# 1735 Giffers
#
# =======================================================================
#
# @(#) $Id: PerlFilter.pm,v 1.4 2006/01/31 17:46:06 aeby Exp $
#
# Revision History:
#
# $Log: PerlFilter.pm,v $
# Revision 1.4  2006/01/31 17:46:06  aeby
# filter(): avoid warnings about uninitialized values
# analyze_sub(): added some more argument recognition patterns
#
# Revision 1.3  2006/01/31 16:53:52  aeby
# added copyright info
#
#
# =======================================================================

## @file
# implementation of DoxyGen::PerlFilter.
#

## @class
# Filter from perl syntax API docs to Doxygen-compatible syntax.
# This class is meant to be used as a filter for the
# <a href="http://www.doxygen.org/">Doxygen</a> documentation tool.
package DoxyGen::PerlFilter;

use warnings;
use strict;
use base qw(DoxyGen::Filter);
my $id = __PACKAGE__;

## @method void filter($infh)
# Do the filtering.
# @param infh input filehandle, normally STDIN
sub filter {
    my ( $self, $infile ) = @_;
    open( my $infh, $infile );
    my $current_class = "";
    my $file          = [];
    my $endMark       = 1;
    my ( $cc, $cl, $lc, $ll ) = ( 0, 0, 0, 0 );
    while (<$infh>) {
        $endMark = 0 if (/^\s*use\s+AutoLoader/);
        last if ( $endMark and /^__END__$/ );

        #next if (/^$/);
        $cc = ( /^\s*#/           ? 1 : 0 );
        $lc = ( /[\{\}\[\];]\s*$/ ? 1 : 0 );
        if ( $cc or $cl or $ll or not(@$file) ) {
            push( @$file, $_ );
        }
        else {
            $file->[ $#{$file} ] =~ s/[\r\n]/ /g;
            $file->[ $#{$file} ] .= $_;
        }
        $cl = $cc;
        $ll = $lc;
        $cl++ if (/\s#/);
    }

    #print STDERR @$file;
    $self->file_contents($file);
    my $objcontext =
         grep( /^\s*use\s+base\s/, @$file )
      || grep( /\@ISA/,           @$file )
      || grep( /^\s*bless/,       @$file )
      || grep( /^\s*sub\s+new\s/, @$file )
      || grep( /\$self/,          @$file );

    push( @$file, "" );    # in order to have a delimiting empty line at EOF
    for ( my $line = 0 ; $line <= $#$file ; ) {
        $_ = $file->[ $line++ ];
        last if ( $endMark and /^__END__$/ );
        if (/^##\s*\@(\S+)\s*(.*)/) {
            my ( $command, $args ) = ( $1, $2 );
            my @more;
            while ( $_ = $file->[ $line++ ] ) {
                if (/^#\s?(.+)/s) {
                    push @more, $1;
                }
                else {
                    last;
                }
            }
            if ( $command eq 'file' ) {
                $args ||= $infile;
                $self->start("\@$command $args");
                $self->more(@more);
                $self->end;
            }
            elsif ( $command eq 'class' ) {
                $objcontext = 1;
                unless ($args) {
                    ($args) = /package\s(.*);/;
                }
                if ($current_class) {
                    $self->flush;
                    $self->print("};\n");
                }
                $current_class = $args;
                die "$line $command $args" unless($args);
                $self->emit_class( $args, $line,
                    [ "\@$command $args", @more, "\@nosubgrouping" ] );
            }
            elsif ( $command eq 'imethod' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push(
                    $self->protection($args) . ' Initialization Methods' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'apmethod' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push( $self->protection($args)
                      . ' Authentication Process Methods' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'rmethod' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push( $self->protection($args) . ' Running Methods' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'cmethod' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push( $self->protection($args) . ' Class Methods' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'ifn' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push(
                    $self->protection($args) . ' Initialization Functions' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'rfn' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push( $self->protection($args) . ' Running Functions' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'fn' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push( $self->protection($args) . ' Functions' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'method' ) {
                unless ($args) {
                    ($args) = $self->analyze_sub( $line - 1 );
                }
                $args = $self->munge_parameters($args);
                $self->push( $self->protection($args) . ' Object Methods' );
                $self->start("\@fn $args")->more(@more)->end;
                $self->print( $args, ";\n" );
                $self->pop;
            }
            elsif ( $command eq 'enum' ) {
                $self->start("\@$command $args");
                $self->more(@more);
                $self->end;
                $self->print("$command $args;\n");
            }
            else {
                $self->start("\@$command $args");
                $self->more(@more);
                $self->end;
            }

            # We ate a line when we got the rest of the comment lines
            redo if defined $_;
        }
        elsif (/^use\s+([\w:]+)/) {
            my $inc = $1;

            #$inc =~ s/::/\//g;
            $self->print("#include \"$inc.pm\"\n");
        }
        elsif (/^package\s+([\w:]+)/) {
            if ($current_class) {
                $self->flush;
                $self->print("};\n");
            }
            next unless ($objcontext);
            $current_class = $1;
            $self->emit_class( $current_class, $line );
        }
        elsif (/^sub\s+([\w:]+)/) {
            my ( $proto, $name, @args ) = $self->analyze_sub( $line - 1 );
            if ( $current_class && @args && ( $args[0] eq "\$self" ) ) {
                $self->push( $self->protection($proto) . ' Object Methods' );
                $proto =~ s/\$self,*\s*//;
            }
            elsif ( $current_class && @args && ( $args[0] eq "\$self" ) ) {
                $self->push(
                    $self->protection($proto) . ' Initialization Methods' );
                $proto =~ s/\$self,*\s*//;
            }
            elsif (
                $current_class
                && (   ( @args && ( $args[0] eq "\$class" ) )
                    || ( $name eq "new" ) )
              )
            {
                $self->push( $self->protection($proto) . ' Class Methods' );
            }
            else {
                $self->push( $self->protection($proto) . ' Functions' );
            }
            $proto = $self->munge_parameters($proto);
            $self->print( $proto, ";\n" );
            $self->pop;
        }
    }
    $self->flush();
    if ($current_class) {
        $self->print("};\n");
    }
}

## @method @ analyze_sub( int line )
# analyzes a subroutine declaration starting at the given line. Tries
# to determine whicht arguments it takes.
#
# @param line The line number at which the sub starts
# @return A function prototype, the name of the function and a
#   list of arguments it takes
sub analyze_sub {
    my ( $self, $line ) = @_;

    my $file = $self->file_contents();
    $file->[$line] =~ /^sub\s+(.*)\{/;
    my $name = $1;
    my $proto;
    my @args;
    if ( $name =~ /^(.*)\s*\((.*)\)/ ) {
        $name  = $1;
        $proto = $2;
    }
    else {
        my $forward = 5;
        for (
            my $i = 0 ;
            $forward && ( $i + $line <= $#$file ) && !$proto ;
            $i++
          )
        {
            $_ = $file->[ $i + $line ];
            if (/^\s*my\s*\((.*)\)\s*=\s*\@_/) {
                $proto = $1;
            }
            elsif (/^\s*(local|my)\s*([^\s]*)\s*=\s*shift\s*;/) {
                push( @args, $2 );
            }
            elsif (/^\s*(local|my)\s*([^\s]*)\s*=\s*\$_\[\s*(\d+)\s*]/) {
                $args[$3] = $2;
            }
            elsif (/shift\s*->\s*[a-z0-9_]+\(/) {

                # assuming anonymously used shifted value is $self
                push( @args, '$self' );
            }
            elsif ( /^\s*\n/ || /^\s*#/ ) {
                ;
            }
            elsif (/}/) {
                $forward = 0;
            }
            else {
                $forward--;
            }
        }
    }
    if ($proto) {
        $proto =~ s/\s+//g;
        $proto =~ s/,/, /g;
        @args = split( ", ", $proto );
    }

    $name =~ s/\s+$//;
    my $protection = "";
    if ( substr( $name, 0, 1 ) eq "_" ) {
        $protection = "protected";
    }
    return ( "$protection retval $name( " . join( ", ", @args ) . " )",
        $name, @args );
}

## @method emit_class( string class, int line, arrayref doc )
# Emit one class definition. If the doc parameter is defined,
# emits the array as a comment just before the class definition,
# otherwise, only the class definition is emitted.
#
# @param class the name of the class
# @param line the current line number
# @param doc (optional) an array with comment lines
sub emit_class {
    my ( $self, $class, $line, $doc ) = @_;

    my ( @current_isa, @current_priv_isa, @current_include, %links );
    my $file = $self->file_contents();
    while ( $_ = $file->[ $line++ ] ) {
        if (/^\s*(?:use base|\@ISA\s*=|\@${class}::ISA\s*=)\s+(.+);/) {
            push @current_isa, eval $1;
            $file->[ $line - 1 ] = "\n";
        }
        elsif (/^\s*(?:use|require)\s+([\w:]+)/) {
            my $inc = $1;
            $links{ $1 || 'public' }{$inc} = $2 . ( $3 ? "\n* $3" : '' )
              if (
/#\s*link\s+(?:(private|protected|public)\s+)?(\S+)(?:\s+(.*))?\s*$/
              );
            push @current_priv_isa, $inc if (/#\s*inherits/);
            $inc =~ s/::/\//g;
            $inc =~
s#Lemonldap/NG/(\w+)#"lemonldap-ng-".lc($1)."/lib/Lemonldap/NG/$1"#e;

            #print STDERR $inc;
            push @current_include, $inc;
            $file->[ $line - 1 ] = "\n";
        }
        elsif (/^package/) {
            last;
        }
        elsif (/#\s*inherits\s+([\w:]+)/) {
            push @current_priv_isa, $1;
        }
        elsif (
/#\s*link\s+([\w:]+)\s+(?:(private|protected|public)\s+)?(\S+)(?:\s+(.*))?\s*$/
          )
        {
            $links{ $2 || 'public' }{$1} = $3 . ( $4 ? "\n* $4" : '' );
        }
    }

    $self->print("#include \"$_.pm\"\n") foreach @current_include;
    $self->print("\n");

    if ($doc) {
        $self->start( $doc->[0] );
        $self->more( @$doc[ 1 .. $#$doc ] );
        $self->end();
    }
    die unless($class);
    $self->print("class $class");

    if ( @current_isa or @current_priv_isa ) {
        my @tmp;
        @tmp = map { "public $_" } @current_isa;
        if ( $ENV{COLLABORATIVE_GRAPH} ) {
            foreach my $type (qw(public protected private)) {
                push @tmp, map { "$type $_" } keys %{ $links{$type} };
            }
        }
        push @tmp, map { "private $_" } @current_priv_isa;
        $self->print( ":", join( ", ", @tmp ) );
    }
    $self->print(" {\n");
    foreach my $target (qw(private protected public)) {
        if ( $links{$target} ) {
            $self->print("$target:\n");
            foreach ( keys %{ $links{$target} } ) {
                $self->print("/** \@var $_ $links{$target}{$_}\n");
                $links{$target}{$_} =~ s/\n.*$//s;
                $self->print("*/\n$_ $links{$target}{$_};\n");
            }
        }
    }
    $self->print("public:\n") unless ( $links{public} );
}

## @method arrayref file_contents( arrayref contents )
# set/get an array containing the whole input file, each
# line at one array index.
#
# @param contents (optional) file array ref
# @return The file array ref
sub file_contents {
    my ( $self, $contents ) = @_;

    $self->{"$id file"} = $contents if ( defined $contents );
    return ( $self->{"$id file"} );
}

## @method munge_parameters($args)
# Munge the argument list. Because DoxyGen does not seem to handle $, @ and %
# as argument types properly, we replace them with full length strings.
#
# @param args String specifying anything after a directive
# @return Processed string.
sub munge_parameters {
    my ( $this, $args ) = @_;

    $args =~ s/\$\@/scalar_or_list /g;
    $args =~ s/\@\$/scalar_or_list /g;
    $args =~ s/\$/scalar /g;
    $args =~ s/\@/list /g;
    $args =~ s/\%/hash /g;

    #    my ($ret, $remainder) = ($args =~ /^\s*(\S+)(.+)/);
    #    if ($ret) {
    #        if ($ret eq '$') {
    #            $ret = 'scalar';
    #        } elsif ($ret eq '@') {
    #            $ret = 'list';
    #        } elsif ($ret eq '$@') {
    #            $ret = 'scalar_or_list';
    #        } elsif ($ret eq '@$') {
    #            $ret = 'list_or_scalar';
    #        }
    #
    #        $args = "$ret$remainder";
    #    }

    return $args;
}

1;