#!/usr/bin/perl
use strict;
use warnings;
##############################################################################
# perltoxmi - extract class definitions from oo perl code, and write out xmi 
#  for import into CASE tools
# Charles Colbourn June 2006
#
##############################################################################
# HISTORY
#
# 0.01	CColbourn	20060616		Rough first version
#
##############################################################################
# TO DO
#
# Error checking
# Write to file instead of STDOUT
# Clean up, abstract and make readable
# detect require as well as use
# detect double quoted attrib names just in case
#
##############################################################################
# Usage
# perltoxmi MyClass.pm MyOtherClass.pm > classes.xmi
# OR
# cat *.pm |perltoxmi >classes.xmi
#
##############################################################################
# Notes
#
# The XMI output is cut and pasted from ArgoUML output. Pretty it isn't, but
# it seems to work
# Export your classes into xmi, then import xmi into Argo (works with v0.20
# definitely). Can use 'add namespace
# to class diagram', and 'layout' to do an
# initial layout.
# It exports any classes included with 'use' but outside the files it's been
# passed as interfaces (which aren't automatically added into class diagrams,
# handily - otherwise there would be hundreds of association lines to 'strict')
# To extract attributes, they need to have been used in the form
# $self->{attrib} (single quotes permitted, but
# '$self' is essential).
#
# It's a dirty, dirty hack, but it does what I need :-)
#
##############################################################################

# 16 hex digits in counter

my ($header, $classtemplate, $attribtemplate, $methodtemplate, $generalisetemplate, $footer, $interfacetemplate, $associationtemplate);
{
	local $/ = '%%ENDOFTEMPLATE%%';

	$header = <DATA>;
	$classtemplate = <DATA>;
	$interfacetemplate = <DATA>;
	$attribtemplate = <DATA>;
	$methodtemplate = <DATA>;
	$generalisetemplate = <DATA>;
	$associationtemplate = <DATA>;
	$footer = <DATA>;
}

my $counter = 2000;
my $package;
my %obj;

while (<>)
{
	if ($_ =~/package ([\w:]+);/)
	{
		$package = $1;
		$obj{$1} = {};
	}

	if ($_=~/use\s+([\w\:]+);/)
	{
		$obj{$package}{uses}{$1}++;
	}

	if ($_ =~/use base\s+(?:qw\(|\'|\")([\w\:\s]+)/)
	{
		my (@parents) = $1=~/([\w\:]+)/g;
		for (@parents)
		{
			$obj{$package}{parents}{$_}++
		}
	}

	if ($_ =~/sub\s+(\w+)/)
	{
		#print $package."::".$1."\n";
		$obj{$package}{methods}{$1}++;
	}

	if ($_ =~/\$self->\{[\']*([\w\s]*)\}/)
	{
		#print $package."->$1\n"
		$obj{$package}{attribs}{$1}++;
	}
}





my %classnametocounter;
my %generalisations;
my %associations;
my $interfacexml;
my %interfaces;

my $xml = "";	

for $package (keys %obj)
{
	my $classprintcounter = sprintf("%016X",++$counter);
	my $class = $classtemplate;
	$class=~s/%%CLASSNAME%%/$package/g;
	$class=~s/%%COUNTER%%/$classprintcounter/g;

	my $attribsxml = "";
	for (keys %{$obj{$package}{attribs}})
	{
		my $attrib = $attribtemplate;
		$attrib=~s/%%ATTRIBNAME%%/$_/;

		my $printcounter = sprintf("%016X",++$counter);
		$attrib =~s/%%COUNTER%%/$printcounter/;

		my $visibility = "public";
		if ($_=~/^\_/){$visibility = "private"}
		$attrib =~s/%%VISIBILITY%%/$visibility/g;

		$attribsxml .= $attrib;
	}

	my $methodsxml = "";
	for (keys %{$obj{$package}{methods}})
	{
		my $method = $methodtemplate;
		$method=~s/%%METHODNAME%%/$_/;

		my $printcounter = sprintf("%016X",++$counter);
		$method =~s/%%COUNTER%%/$printcounter/;

		my $visibility = "public";
		if ($_=~/^\_/){$visibility = "private"}
		$method =~s/%%VISIBILITY%%/$visibility/g;

		$methodsxml .= $method;
	}


	$classnametocounter{$package} = $classprintcounter;

	for (keys %{$obj{$package}{parents}})
	{
		$generalisations{$package} = $_;
	}

	for (keys %{$obj{$package}{uses}})
	{
		$interfaces{$_}++;
		$associations{$package}{$_}++;
	}

	$class =~s/%%ATTRIBXML%%/$attribsxml/;
	$class =~s/%%METHODXML%%/$methodsxml/;

	$xml .= $class;
}


for my $intname (keys %interfaces)
{
	if ($obj{$intname}){next} # don't create an interface if the class is in read scope

	my $printcounter = sprintf("%016X",++$counter);
	my $interface = $interfacetemplate;
	$interface=~s/%%INTERFACENAME%%/$intname/g;
	$interface=~s/%%COUNTER%%/$printcounter/g;

	$classnametocounter{$intname} = $printcounter;
	$xml .= $interface;
}


for (keys %generalisations)
{
	my $generalisation = $generalisetemplate;
	my $childcounter = $classnametocounter{$_};
	my $parentcounter = $classnametocounter{$generalisations{$_}};
	$generalisation =~s/%%CHILDCOUNTER%%/$childcounter/;
	$generalisation =~s/%%PARENTCOUNTER%%/$parentcounter/;

	my $printcounter = sprintf("%016X",++$counter);
	$generalisation =~s/%%COUNTER%%/$printcounter/;
	#take out the association - we don't want both a vanilla association and a generalisation
	if ($associations{$_}{$generalisations{$_}}){delete $associations{$_}{$generalisations{$_}}}		

	$xml .= $generalisation;
}



for my $package(keys %associations)

{

	for my $association (keys %{$associations{$package}})
	{
		my $associationxml = $associationtemplate;
		my $usingclasscounter = $classnametocounter{$package};
		my $usedclasscounter = $classnametocounter{$association};
		$associationxml =~s/%%USINGCLASS%%/$usingclasscounter/;
		$associationxml =~s/%%USEDCLASS%%/$usedclasscounter/;

		my $printcounter = sprintf("%016X",++$counter);

		$associationxml =~s/%%COUNTER%%/$printcounter/;

		my $usedclassendcounter = sprintf("%016X",++$counter);

		$associationxml =~s/%%USEDENDCOUNTER%%/$usedclassendcounter/;

		my $usingclassendcounter = sprintf("%016X",++$counter);

		$associationxml =~s/%%USINGENDCOUNTER%%/$usingclassendcounter/;

		
		$xml .= $associationxml;
	}
}


# get rid of the template markers

$xml=~s/%%ENDOFTEMPLATE%%//sg;
$header =~s/%%ENDOFTEMPLATE%%//sg;
$footer=~s/%%ENDOFTEMPLATE%%//sg;

print $header."\n";
print $xml;
print $footer."\n";


__DATA__

<?xml version = '1.0' encoding = 'UTF-8' ?>
<XMI xmi.version = '1.2' xmlns:UML = 'org.omg.xmi.namespace.UML' timestamp = 'Thu Jun 15 12:59:02 BST 2006'>
  <XMI.header>  <XMI.header>
    <XMI.documentation>
      <XMI.exporter>ArgoUML (using Netbeans XMI Writer version 1.0)</XMI.exporter>
      <XMI.exporterVersion>0.20.x</XMI.exporterVersion>
    </XMI.documentation>
    <XMI.metamodel xmi.name="UML" xmi.version="1.4"/>  </XMI.header>
</XMI.header>
  <XMI.content>
    <UML:Model xmi.id = '.:0000000000000001' name = 'UNNAMED' isSpecification = 'false'
      isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>

%%ENDOFTEMPLATE%%

      <UML:Namespace.ownedElement>
        <UML:Class xmi.id = '.:%%COUNTER%%' name = '%%CLASSNAME%%' visibility = 'public'
          isSpecification = 'false' isRoot = 'false' isLeaf = 'false' isAbstract = 'false'
          isActive = 'false'>
          <UML:Classifier.feature>

%%ATTRIBXML%%

%%METHODXML%%

          </UML:Classifier.feature>
        </UML:Class>
   </UML:Namespace.ownedElement>

%%ENDOFTEMPLATE%%

      <UML:Namespace.ownedElement>
        <UML:Interface xmi.id = '.:%%COUNTER%%' name = '%%INTERFACENAME%%' visibility = 'public'
          isSpecification = 'false' isRoot = 'false' isLeaf = 'false' isAbstract = 'false'
          isActive = 'false'/>
		</UML:Namespace.ownedElement>

%%ENDOFTEMPLATE%%

            <UML:Attribute xmi.id = '.:%%COUNTER%%' name = '%%ATTRIBNAME%%' visibility = '%%VISIBILITY%%'
              isSpecification = 'false' ownerScope = 'instance' changeability = 'changeable'
              targetScope = 'instance'>
            </UML:Attribute>

%%ENDOFTEMPLATE%%

            <UML:Operation xmi.id = '.:%%COUNTER%%' name = '%%METHODNAME%%' visibility = '%%VISIBILITY%%'
              isSpecification = 'false' ownerScope = 'instance' isQuery = 'false' concurrency = 'sequential'
              isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>
            </UML:Operation>

%%ENDOFTEMPLATE%%

<UML:Namespace.ownedElement>
        <UML:Generalization xmi.id = '.:%%COUNTER%%' isSpecification = 'false'>
          <UML:Generalization.child>
            <UML:Class xmi.idref = '.:%%CHILDCOUNTER%%'/>
          </UML:Generalization.child>
          <UML:Generalization.parent>
            <UML:Class xmi.idref = '.:%%PARENTCOUNTER%%'/>
          </UML:Generalization.parent>
        </UML:Generalization>
	</UML:Namespace.ownedElement>

%%ENDOFTEMPLATE%%

<UML:Namespace.ownedElement>
        <UML:Association xmi.id = '.:%%COUNTER%%' name = 'uses' isSpecification = 'false'
          isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>
          <UML:Association.connection>
            <UML:AssociationEnd xmi.id = '.:%%USINGENDCOUNTER%%' visibility = 'public'
              isSpecification = 'false' isNavigable = 'false' ordering = 'unordered' aggregation = 'none'
              targetScope = 'instance' changeability = 'changeable'>
              <UML:AssociationEnd.participant>
                <UML:Class xmi.idref = '.:%%USINGCLASS%%'/>
              </UML:AssociationEnd.participant>
            </UML:AssociationEnd>
            <UML:AssociationEnd xmi.id = '.:%%USEDENDCOUNTER%%' visibility = 'public'
              isSpecification = 'false' isNavigable = 'true' ordering = 'unordered' aggregation = 'none'
              targetScope = 'instance' changeability = 'changeable'>
              <UML:AssociationEnd.participant>
                <UML:Interface xmi.idref = '.:%%USEDCLASS%%'/>
              </UML:AssociationEnd.participant>
            </UML:AssociationEnd>
          </UML:Association.connection>
        </UML:Association>
	</UML:Namespace.ownedElement>

%%ENDOFTEMPLATE%%

    </UML:Model>
  </XMI.content>
</XMI>

%%ENDOFTEMPLATE%%