Beefy Boxes and Bandwidth Generously Provided by pair Networks
Don't ask to ask, just ask
 
PerlMonks  

perltoxmi

by g0n (Priest)
on Jun 16, 2006 at 19:03 UTC ( #555854=sourcecode: print w/ replies, xml ) Need Help??

Category: Utility Scripts
Author/Contact Info Charles Colbourn /msg g0n
Description: Rough and ready way to convert oo perl code to xmi for uml class diagrams, for import into Argo/Rose/etc etc.
#!/usr/bin/perl
use strict;
use warnings;
######################################################################
+########
# perltoxmi - extract class definitions from oo perl code, and write o
+ut 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 di
+agrams,
# 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, $genera
+lisetemplate, $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 associati
+on 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' times
+tamp = 'Thu Jun 15 12:59:02 BST 2006'>
  <XMI.header>  <XMI.header>
    <XMI.documentation>
      <XMI.exporter>ArgoUML (using Netbeans XMI Writer version 1.0)</X
+MI.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' isSpecif
+ication = 'false'
      isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>

%%ENDOFTEMPLATE%%

      <UML:Namespace.ownedElement>
        <UML:Class xmi.id = '.:%%COUNTER%%' name = '%%CLASSNAME%%' vis
+ibility = '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 = '%%INTERFACENAM
+E%%' visibility = 'public'
          isSpecification = 'false' isRoot = 'false' isLeaf = 'false' 
+isAbstract = 'false'
          isActive = 'false'/>
        </UML:Namespace.ownedElement>

%%ENDOFTEMPLATE%%

            <UML:Attribute xmi.id = '.:%%COUNTER%%' name = '%%ATTRIBNA
+ME%%' visibility = '%%VISIBILITY%%'
              isSpecification = 'false' ownerScope = 'instance' change
+ability = 'changeable'
              targetScope = 'instance'>
            </UML:Attribute>

%%ENDOFTEMPLATE%%

            <UML:Operation xmi.id = '.:%%COUNTER%%' name = '%%METHODNA
+ME%%' visibility = '%%VISIBILITY%%'
              isSpecification = 'false' ownerScope = 'instance' isQuer
+y = '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' isSpec
+ification = 'false'
          isRoot = 'false' isLeaf = 'false' isAbstract = 'false'>
          <UML:Association.connection>
            <UML:AssociationEnd xmi.id = '.:%%USINGENDCOUNTER%%' visib
+ility = '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%%' visibi
+lity = '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%%

Comment on perltoxmi
Download Code

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://555854]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others perusing the Monastery: (6)
As of 2014-11-23 14:44 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My preferred Perl binaries come from:














    Results (132 votes), past polls