view release on metacpan or  search on metacpan

lib/Autodia/Diagram.pm  view on Meta::CPAN

    # check to see if package of this name already exists
    my $exists = $self->_package_exists($component);

    if (ref($exists))
    {
      if ($exists->Type eq "Component")
	{
	  # replace self with already present component
	  $component->Redundant($exists);
	  $return = $exists;
      	}
    }
    else
    {
	# component is new and unique
	$self->_package_add($component);
	$component->Set_Id($self->_object_count);
    }

    return $return;
}

sub add_superclass
{
  my $self = shift;
  my $superclass = shift;
  my $return = 0;

  # check to see if package of this name already exists
  my $exists = $self->_package_exists($superclass);

  if (ref($exists))
    {
      if ($exists->Type eq "superclass")
	{ $return = $exists;}
      else { print STDERR "eek!! wrong type of object returned by _package_exists\n"; }
    }
  else
    {
      $self->_package_add($superclass);
      $superclass->Set_Id($self->_object_count);
    }
  return $return;
}

sub add_class
{
    my $self = shift;
    my $class = shift;

    # some perl modules such as CGI.pm do things by redeclaring packages - eek!
    # this is a nasty hack to get around that nasty hack. ie class is not added
    # to diagram and so everything is discarded until next new package declared
    if (defined $self->{"packages"}{"class"}{$class->Name})
      {
	print STDERR "Diagram.pm : add_class : ignoring duplicate class",
	  $class->Name, "\n";
#	warn Dumper (original_class=>$self->{"packages"}{"class"}{$class->Name});
	return $self->{"packages"}{"class"}{$class->Name};
      }
    # note : when running benchmark.pl this seems to appear which I guess is a
    # scoping issue when calling autodial multiple times - odd, beware if using
    # mod_perl or something similar, not that it breaks anything but you never know

    $class->Set_Id($self->_object_count);
    $self->_package_add($class);

    return $class;
}

sub remove_duplicates
  {
    my $self = shift;

    if (defined $self->{"packages"}{"superclass"})
      {
	my @superclasses = @{$self->Superclasses};
	foreach my $superclass (@superclasses)
	  {
	    # if a component exists with the same name as the superclass
	    if (defined $self->{"packages"}{"Component"}{$superclass->Name})
	      {
		my $component = $self->{"packages"}{"Component"}{$superclass->Name};
		# mark component redundant
		$component->Redundant;
		# remove component
		$self->_package_remove($component);
		# kill its dependancies
		foreach my $dependancy ($component->Dependancies)
		  {
		    # remove dependancy
		    $self->_package_remove($dependancy);
		  }
	      }
	  }
      }

    if (defined $self->{"packages"}{"class"})
      {
	my @classes = @{$self->Classes};
	foreach my $class (@classes)
	  {
	    # if a superclass exists with the same name as the class
	    if (defined $self->{"packages"}{"superclass"}{$class->Name})
	      {
		# mark as redundant, remove and steal its children
		my $superclass = $self->{"packages"}{"superclass"}{$class->Name};
		$superclass->Redundant;
		$self->_package_remove($superclass);
		foreach my $inheritance ($superclass->Inheritances) {
		    if (ref($inheritance)) {
			$inheritance->Parent($class->Id); 
		    } else {
			warn "problem with inheritance : $inheritance - class : ",$class->Name,"\n";
		    }
		}
		$class->has_child(scalar $superclass->Inheritances);

		foreach my $relation ($superclass->Relations) {
		    $relation->Right($class);
		}