################################################################
# AutoDIA - Automatic Dia XML.   (C)Copyright 2001 A Trevena   #
#                                                              #
# AutoDIA comes with ABSOLUTELY NO WARRANTY; see COPYING file  #
# This is free software, and you are welcome to redistribute   #
# it under certain conditions; see COPYING file for details    #
################################################################

#  Now actually works (ish) thanks to Ekkehard ! significant   #
#   amounts of  this code contributed by Ekkehard Goerlach     #

package HandlerCpp;

require Exporter;

use strict;

use vars qw($VERSION @ISA @EXPORT);
use Handler;

@ISA = qw(Handler Exporter);

use Diagram;

#---------------------------------------------------------------

#####################
# Constructor Methods

# new inherited from Handler

#------------------------------------------------------------------------
# Access Methods

# parse_file inherited from Handler

#-----------------------------------------------------------------------------
# Internal Methods

# _initialise inherited from Handler

sub _parse
  {
    my $self     = shift;
    my $fh       = shift;
    my $filename = shift;
    my $Diagram  = $self->{Diagram};

    print "processing file : $filename \n";

    my $Class;

    $self->{current_package} = $filename;
    $self->{privacy}         = 0;
    $self->{comment}         = 0;
    $self->{in_class}        = 0;
    $self->{in_declaration}  = 0;
    $self->{in_method}       = 0;
    $self->{brace_depth}     = 0;

    my $i = 0;

    # parse through file looking for stuff
    while (<$fh>)
      {
      LINE:
	{
	  chomp(my $line=$_);
	  if ($self->_discard_line($line)) { last LINE; }

	  print "line $i : $line \n";
	  $i++;

	  # check for class declaration
	  if ($line =~ m/^\s*class\s+(\w+)/)
	    {

	      print "found class : $line \n";

	      my $classname = $1;
	      $self->{in_class} = 1;
	      $self->{privacy} = "private";
	      $self->{visibility} = 1;
	      $Class = DiagramClass->new($classname);
	      $Diagram->add_class($Class);

	      # handle superclass(es)
	      if ($line =~ m/^\s*class\s+\w+\s*\:(.+)/)
		{
		  my $superclasses = $1;
		  chomp $superclasses;
		  print "found superclasses : $superclasses\n";
		  my @superclasses = split (",", $superclasses);
		  foreach my $super (@superclasses)
		    {
		      chomp $super;
		      $super =~ s/^\s*\w+\s+([A-Za-z0-9\_]+)$/$1/;
		      my $Superclass = DiagramSuperclass->new($super);
		      my $exists_already = $Diagram->add_superclass($Superclass);
		      if (ref $exists_already)
			{ $Superclass = $exists_already; }
		      my $Inheritance = DiagramInheritance->new($Class, $Superclass);
		      $Superclass->add_inheritance($Inheritance);
		      $Class->add_inheritance($Inheritance);
		      $Diagram->add_inheritance($Inheritance);
		    }
		}
	      last LINE;
	    }

	  # check for end of class declaration
	  if ($self->{in_class} && ($line =~ m|^\s*\}\;|))
	    {
	      print "found end of class\n";
	      $self->{in_class} = 0;
	      $self->{privacy} = 0;
	      last LINE;
	    }

	  # check for abstraction/data hiding
	  if ($self->{in_class})
	    {
	      if ($line =~ m/^\s*protected\s*\:/)
		{
		  print "found protected variables/classes\n";
		  $self->{privacy} = "protected";
		  $self->{visibility} = 1;
		  last LINE;
		}

	      if ($line =~ m/^\s*private\s*\w*\:/)
		{
		  print "found private variables/classes\n";
		  $self->{privacy} = "private";
		  $self->{visibility} = 1;
		  last LINE;
		}

	      if ($line =~ m/^\s*public\s*\w*\:/)
		{
		  print "found public variables/classes\n";
		  $self->{privacy} = "public";
		  $self->{visibility} = 0;
		  last LINE;
		}

	      if ($line =~ m/operator/)
		{
		  print "found overloaded operator\n";
		  last LINE if $line =~ /;/;

		  while ($line !~ /{/)
		    {
		      $line = <$fh>;
		      print "waiting for start of overload def: $line\n";
		    }
		  my $start_brace_cnt = $line =~ tr/{/{/ ;
		  my $end_brace_cnt   = $line =~ tr/}/}/ ;

		  $self->{brace_depth} = $start_brace_cnt - $end_brace_cnt;
		  $self->{in_method}   = 1 unless $self->{brace_depth}  == 0;
		  print "OvStart: ",$start_brace_cnt, $end_brace_cnt, $self->{brace_depth}, $self->{in_method} ,"\n";

		  last LINE;
		}

	      # if inside a class method then discard line
	      if ($self->{in_method})
		{
		  # count number of braces and increment decrement depth accordingly
		  # if depth = 0 then reset in_method and next;
		  # else next;
		  my $start_brace_cnt = $line =~ tr/{/{/ ;
		  my $end_brace_cnt   = $line =~ tr/}/}/ ;

		  $self->{brace_depth} = $self->{brace_depth} + $start_brace_cnt - $end_brace_cnt;
		  $self->{in_method}   = $self->{brace_depth}  == 0 ? 0 : 1;

		  print "In method: ",$start_brace_cnt, $end_brace_cnt, $self->{brace_depth}, $self->{in_method} ,"\n";
		  last LINE;
		}

	      # check for simple declarations
	      if ($line =~ m/^\s*(\w+\s*\*?)\s*(\w+)\;.*$/)
		{
		  my $name = $2;
		  my $type = $1;
		  print "found simple variable declaration : name = $name, type = $type\n";

		  #my $visibility = ( $name =~ m/^\_/ ) ? 1 : 0;

		  $Class->add_attribute({
					 name => $name,
					 visibility => $self->{visibility},  #was: $visibility,
					 type => $type,
					});

		  last LINE;
	      }

	      # check for simple sub
	      if ($line =~ m/^                       # start of line
                            \s*                      # whitespace
                            (\w*?\s*?\w*?\*?)        # type of the method: $1
                            \s*                      # whitespace
                            (~?\w+)                  # name of the method: $2
                            \s*                      # whitespace
                            \(\s*                    # start of parameter list
                            ([\w\,\s\*=&\"]*)        # all parameters: $3
                            (\)?)                    # may be an ending bracket: $4
                            [\w\s=]*(;?)             # possibly end of signature $5
                            .*$/x
		 )
		{
		  my $name = $2;
		  my $type = $1 || "void";
		  my $params = $3;
		  my $end_bracket = $4;
		  my $end_semicolon = $5;

		  my $have_continuation = 0;
		  my $have_end_semicolon= 0;

		  if ($name eq $Class->{"name"})
		    {
		      print "found constructor declaration : name = $name\n";
		      $type = "";
		    }
		  else
		    {
		      if ($name eq "~".$Class->{"name"})
			{
			  print "found destructor declaration : name = $name\n";
			  $type = "";
			}
		      else
			{
			  print "found simple function declaration : name = $name, type = $type\n";
			}
		    }

		  $have_continuation  = 1 unless $end_bracket    eq ")";
		  $have_end_semicolon = 1 if     $end_semicolon  eq ";";

		  print $have_continuation  ? "no ":"with " ,"end bracket : $end_bracket\n";
		  print $have_end_semicolon ? "with ":"no " ,"end semicolon : $end_semicolon\n";

		  $params    =~ s|\s+$||;
		  my @params = split(",",$params);
		  my $pc = 0; # parameter count

		  my %subroutine = (
				    name       => $name,
				    type       => $type,
				    visibility => $self->{visibility},
				   );

		  # If we have continuation lines for the parameters get them all
		  while ($have_continuation)
		    {
		      my $line = <$fh>;
		      chomp $line;
		      print "line $i (cont) : $line \n";

		      if ($line =~ m/^                        # start of line
                                     \s*                      # whitespace
                                     ([\w\,\s\*=&\"]*)        # all parameters: $1
                                     (\)?)                    # may be an ending bracket: $2
                                     [\w\s=]*(;?)             # possibly end of signature $3
                                     .*$/x)
			{
			  my $cparams     = $1;
			  $end_bracket    = $2;
			  $end_semicolon  = $3;

			  $cparams =~ s|\s+$||;
			  my @cparams = split(",",$cparams);
			  push @params, @cparams;

			  print "More parameters: >$cparams<\n";

			  $have_continuation  = 0 if ($end_bracket   eq ")");
			  $have_end_semicolon = 1 if ($end_semicolon eq ";");

			  print $have_continuation ? "no ":"with " ,"end bracket : $end_bracket\n";
			  print $have_end_semicolon ? "with ":"no " ,"end semicolon : $end_semicolon\n";
			}
		    }


		  # then get parameters and types
		  my @parameters = ();
		  print "All parameters: ",join(';',@params),"\n";
		  foreach my $parameter (@params)
		    {
		      $parameter =~ s/const\s+//;

		      my ($type, $name) = split(" ",$parameter);

		      $type =~ s/\s//g;
		      $name =~ s/\s//g;

		      $parameters[$pc] = (
					  name => $name,
					  type => $type,
					 );
		      $pc++;
		    }

		  $subroutine{param} = \@parameters;
		  $Class->add_operation(\%subroutine);

		  # Now finished with parameters.  If there was no end
		  # semicolon we have an inline method: we read on until we
		  # see the start of the method. This deals with (multi-line)
		  # constructor initialization lists as well.
                  last LINE if $have_end_semicolon;

		  while ($line !~ /{/)
		    {
		      $line = <$fh>;
		      print "waiting for start of method def: $line\n";
		    }
		  my $start_brace_cnt = $line =~ tr/{/{/ ;
		  my $end_brace_cnt   = $line =~ tr/}/}/ ;

		  $self->{brace_depth} = $start_brace_cnt - $end_brace_cnt;
		  $self->{in_method}   = 1 unless $self->{brace_depth}  == 0;
		  print "Start: ",$start_brace_cnt, $end_brace_cnt, $self->{brace_depth}, $self->{in_method} ,"\n";

		  last LINE;
		}

	      # if line starts with word,space,word then its a declaration (probably)
	      if ($line =~ m/\s*\w+\s+\w+/i)
		{
		  print " probably found a declaration : $line\n";
		  my @words = m/^(\w+)\s*[\(\,\;].*$/g;
		  my $name = $&;
		  my $rest = $';
		  my $type = '';

		  my $pc = 0; # point count (ie location in array)
		  foreach my $start_point (@-)
		    {
		      my $start = $start_point;
		      my $end = $+[$pc];
		      $type .= substr($line, $start, ($end - $start));
		      
		      $pc++;
		    }

		  # if next character is a ( then the line is a function declaration
		  if ($rest =~ m|^\((\w+)\(.*(\;?)\s*$|)
		    {
		      print "probably found a function : $line \n";
		      my $params = $1;
		      my @params = split(",",$params);

		      my $declaration = 0;
		      if (defined $2) # if line ends with ";" then its a declaration
			{
			  $declaration = 1;
			  my @parameters = ();
			  my $pc = 0; # parameter count
			  
			  my %subroutine = (
					    name       => $name,
					    type       => $type,
					    visibility => $self->visibility,
					   );

			  # then get parameters and types
			  foreach my $parameter (@params)
			    {
			      my ($type, $name) = split(" ",$parameter);

			      $type =~ s/\s//g;
			      $name =~ s/\s//g;

			      $parameters[$pc] = (
						  name => $name,
						  type => $type,
						 );
			      $pc++;
			    }

			  $subroutine{param} = \@parameters;
			  $Class->add_operation(\%subroutine);
			}
		      else
			{
			  my @attributes = ();
			  # else next character is , or ; 
			  # the line's a variable declaration
			  $Class->add_attribute ({
						  name       => $name,
						  type       => $type,
						  visibility => $self->{visibility},
						 });
			  my %attribute = { name => $name , type => $type };
			  $attributes[0] = \%attribute;
			  if ($rest =~ m/^\,.*\;/)
			    {
			      my @atts = split (",");
			      foreach my $attribute (@atts)
				{
				my @attribute_parts = split(" ", $attribute);
				my $n = scalar @attribute_parts;
				my $name = $attribute_parts[$n];
				my $type = join(" ",$attribute_parts[0...$n-1]);
				$Class->add_attribute ( {
							 name       => $name,
							 type       => $type,
							 visibility => $self->{visibility},
							});
				#
			      }
			      #
			    }
			  #
		      }
		      # 
		    }
		  #
		}
	    #
	  }
	}
      }

    $self->{Diagram} = $Diagram;
    close $fh;
    return;
  }

sub _discard_line
{
  my $self    = shift;
  my $line    = shift;
  my $discard = 0;

  SWITCH:
    {
	if ($line =~ m/^\s*$/) # if line is blank or white space discard
	{
	    $discard = 1;
	    last SWITCH;
	}

	if ($line =~ /^\s*\/\//) # if line is a comment discard
	{
	    $discard = 1;
	    last SWITCH;
	}

	# if line starts with multiline comment syntax discard and set flag
	if ($line =~ /^\s*\/\*/)
	{
	    $self->{comment} = 1;
	    $discard = 1;
	    last SWITCH;
	}

	if ($self->{comment} == 1) # if currently inside a multiline comment
	  {
	    # if line starts with comment end syntax then unflag and discard
	    if ($line =~ /^.*\*\/\s*$/)
	      {
		$self->{comment} = 0;
		$discard = 1;
		last SWITCH;
	      }

	    $discard = 1;
	    last SWITCH;
	}
    }
    return $discard;
}

####-----

sub _is_package
  {
    my $self    = shift;
    my $package = shift;
    my $Diagram = $self->{Diagram};

    unless(ref $$package)
       {
	 my $filename = shift;
	 # create new class with name
	 $$package = DiagramClass->new($filename);
	 # add class to diagram
	 $Diagram->add_class($$package);
       }

    return;
  }

####-----

1;

###############################################################################

=head1 NAME

HandlerPerl.pm - AutoDia handler for perl

=head1 INTRODUCTION

HandlerPerl parses files into a Diagram Object, which all handlers use. The role of the handler is to parse through the file extracting information such as Class names, attributes, methods and properties.

HandlerPerl parses files using simple perl rules. A possible alternative would be to write HandlerCPerl to handle C style perl or HandleHairyPerl to handle hairy perl.

HandlerPerl is registered in the Autodia.pm module, which contains a hash of language names and the name of their respective language - in this case:

%language_handlers = { .. , perl => "perlHandler", .. };

=head1 CONSTRUCTION METHOD

use HandlerPerl;

my $handler = HandlerPerl->New(\%Config);

This creates a new handler using the Configuration hash to provide rules selected at the command line.

=head1 ACCESS METHODS

$handler->Parse(filename); # where filename includes full or relative path.

This parses the named file and returns 1 if successful or 0 if the file could not be opened.

$handler->output(); # any arguments are ignored.

This outputs the Dia XML file according to the rules in the %Config hash passed at initialisation of the object.

=cut
