Beefy Boxes and Bandwidth Generously Provided by pair Networks
laziness, impatience, and hubris
 
PerlMonks  

Creates an umbrello compliant xmi document from a set of classes

by hanspoo (Initiate)
on Jun 14, 2007 at 15:06 UTC ( [id://621262]=sourcecode: print w/replies, xml ) Need Help??
Category: Miscellaneous
Author/Contact Info Hans Poo, hans@welinux.cl
Description: Create an acceptable representation of a perl object model in xmi. By default prints the xmi document in standard output, this can be overwriten with the parameter --out-file. It's based on an umbrello document retouched incrementally. Classes given in command line are fully loaded and are given different treatement than classes just referenced. This automatically sets a scope for recursion. Classes indicated on command line will ve eval'ed. May be you will need to set PERL5LIB. Cardinality is not considered yet. This script is a good starting point, it's dirty, but works.
#!/usr/bin/perl

use Getopt::Long;

use Devel::Symdump;

my ($childs_of, $methods, $outfile, $exclude, $help, $as_text);
my $res = GetOptions(
    "out-file:s"    => \$outfile,
    "childs-of:s"     => \$childs_of, 
    "exclude:s"     => \$exclude, 
    methods         => \$methods,
    "as-text"         => \$as_text,
    help             => \$help,
);

if ($help) {
    &print_usage;
    exit 0;
}

unless ($exclude) {
    $exclude = "^(Apache|CGI|Data::Dumper|General|Carp)|::General";
}
$pragmas = "^(attributes|attrs|autouse|base|bigint|bignum|bigrat|blib|
+bytes|charnames|constant|diagnostics|encoding|fields|filetest|if|inte
+ger|less|lib|locale|open|ops|overload|re|sigtrap|sort|strict|subs|thr
+eads|utf8|vars|vmsish|warnings)";

my @clases;
my @asocs;

our $doc;

&define_doc;

$last_class = undef;

my $clases_totales = @ARGV;
unless (@ARGV) {
    print STDERR "Please give me some perl classes, try with --help or
+ perldoc for more.\n";
    exit 1;
}

foreach $file (@ARGV) {

    print STDERR "Processing: $file\n";

    open IN, $file or die $!;

    require $file;

    while ($line = <IN>) {

        @words = split /\s+/, $line;

        my $first = shift @words;

        next unless $first =~ /^\s*?(package|use|sub)/;

        my $second = shift @words;

        SWITCH: {

        if ($first eq 'package') {
            $last_class = new Clase($second);
        }
        if ($first eq 'use') {
            next if $second =~ /(no\s+)?$pragmas/;
            next if $second =~ /$exclude/;
            my $newclass = new Clase($second);
            $a = new Asoc ($newclass, $last_class);
        }
        if ($methods && $first eq 'sub') {
            $last_class->add_method($second);
        }
        
        }
    }
    # finalmente, examinemos la tabla de símbolos para buscar el @ISA
    my  $name = $last_class->nombre;
    my @parents;
    eval "\@parents = \@$name" ."::ISA;";
    die $@ if $@;
    foreach (@parents) {
        $last_class->add_parent($_);
    }

    if ($childs_of) {
        pop (@clases) unless $last_class->es_hija($childs_of);
    }
    
}

if ($as_text) {
    &as_text;
} else {
    &gen_umbrello;
}

print STDERR "Complete!!\n";

exit 0;

sub as_text {

foreach $c (@clases) {

    print $c->nombre, "\n";
    print "-" x length($c->nombre), "\n";

    print "methods:\n";
    foreach my $method ($c->methods) {
        print "\t$method\n";
    }

    print "parents:\n";
    foreach my $parent ($c->parents) {
        print "\t", $parent->nombre, "\n";
    }

    print "associations:\n";
    foreach my $asoc (@asocs) {
        
        if ($asoc->c1->nombre eq $c->nombre) {
            print "\t",$asoc->c2->nombre,"\n";
        } 
        if ($asoc->c2->nombre eq $c->nombre) {
            print "\t",$asoc->c1->nombre,"\n";
        } 

    }

}

print "Asociations:\n";
foreach my $asoc (@asocs) {
    print $asoc->c1->nombre, " => ", $asoc->c2->nombre, "\n";
}


}

sub print_usage {

print STDERR <<EOF;

perl2xmi - Creates an umbrello compliant xmi document from a set of cl
+asses.

format:
perl2xmi [--out-file=xxxx] [--methods] [--childs-of=regex] [--exclude=
+regex] [--as-text] *.pm

examples:
perl2xmi *.pm
perl2xmi --methods --out-file=mymodel.xmi *.pm # same, but includes me
+thods

Create an acceptable representation of a perl object model in xmi.
By default prints the xmi document in standard output, this can be ove
+rwritten 
with the parameter --out-file. 

EOF

return 1;

}



package Asoc;

our $ids = 10000;

sub new  {

my ($class, $c1, $c2) = @_;

foreach (@asocs) {
    return $_ if ($_->c1 eq $c1 and $_->c2 eq $c2) or ($_->c1 eq $c2 a
+nd $_->c2 eq $c1);
}

my $self = bless {c1 => $c1, c2 => $c2, id => ++$ids}, $class;
push @asocs, $self; 
return $self;

}

sub id { $_[0]->{id} }
sub c1 { $_[0]->{c1} }
sub c2 { $_[0]->{c2} }


package Clase;

sub new  {

my ($class, $nombre) = @_;

$nombre =~ s/[^A-Z0-9_:]*//ig;

foreach (@clases) {
    return $_ if $_->nombre eq $nombre;
}

my $self = bless {nombre => $nombre}, $class;
push @clases, $self; 
return $self;

}

sub nombre {$_[0]->{nombre}}

sub id {

my $self = shift;

(my $id = $self->nombre) =~ s/\W+//g;

return $id;

}

sub add_parent {

my $self = shift;
my $parent_name = shift;

push @{$self->{parents}}, new Clase($parent_name);

}

sub add_method {

my $self = shift;
my $m = shift;

$m =~ s/^(\w+).*/$1/; # cleanup

return  if grep /^$m$/, @{$self->{methods}};

#foreach (@{$self->{methods}}) {
#    return if $_ eq $m;
#}

push @{$self->{methods}}, $m;

}

sub asocs { @{$_[0]->{asocs}}}
sub parents { @{$_[0]->{parents}}}
sub methods { sort @{$_[0]->{methods}}}

#
# retorna verdadero si la clase es hija de alguna
# clase que haga match con la expresion regular entregada
#
sub es_hija  {

my $self = shift;
my $regex = shift;

foreach ($self->parents) {
    return 1 if /$regex/;
}

return undef;

}

1;

package main;

sub clase_registrada {

my $id_clase = shift;

foreach $c (@clases) {
    return 1 if $c->id eq $id_clase;
}

return undef;

}


sub gen_umbrello {

$newid=1000;

foreach $c (@clases) {

    my $classid = $c->id;

    push @c, <<EOF;
<UML:Class isSpecification="false" isLeaf="false" visibility="public" 
+namespace="Logical View" xmi.id="$classid" isRoot="false" isAbstract=
+"false" name="@{[$c->nombre]}">
EOF
    foreach my $method ($c->methods) {
        my $relid = $newid++;

        push @c, <<EOF;
<UML:Operation isSpecification="false" isLeaf="false" visibility="publ
+ic" xmi.id="$relid" isRoot="false" isAbstract="false" isQuery="false"
+ name="$method" />
EOF
    }

    push @c, <<EOF;
</UML:Class>
EOF

    foreach my $parent ($c->parents) {

        my $relid = $newid++;

        push @c, <<EOF;
<UML:Generalization isSpecification="false" child="$classid" visibilit
+y="public" namespace="Logical View" xmi.id="$relid" parent="@{[$paren
+t->id]}" discriminator="" name="" />
EOF

        push @aw, <<EOF;
     <assocwidget totalcounta="2" indexa="1" totalcountb="2" indexb="1
+" linewidth="none" widgetbid="@{[$parent->id]}" widgetaid="$classid" 
xmi.id="$relid" linecolor="none" >
      <linepath>
       <startpoint startx="0" starty="0" />
       <endpoint endx="100" endy="100" />
      </linepath>
     </assocwidget>
EOF

    }

    my $x = int(rand(800));
    my $y = int(rand(800));

    push @w, <<EOF;
<classwidget usesdiagramfillcolor="1" width="96" showattsigs="601" x="
+$x" fillcolor="none" y="$y" showopsigs="601" linewidth="none" height=
+"36" usefillcolor="1" showpubliconly="0" showattributes="1" isinstanc
+e="0" xmi.id="$classid" showoperations="1" showpackage="0" showscope=
+"1" usesdiagramusefillcolor="1" font="Sans Serif,10,-1,0,75,0,0,0,0,0
+" linecolor="none" />
EOF

}


foreach my $asoc (@asocs) {

    push @a, <<EOF;
  <UML:Association isSpecification="false" visibility="public" namespa
+ce="Logical View" xmi.id="@{[$asoc->id]}" name="" >
   <UML:Association.connection>
    <UML:AssociationEnd isSpecification="false" visibility="public" ch
+angeability="changeable" isNavigable="true" xmi.id="@{[$newid++]}" ag
+gregation="none" type="@{[$asoc->c1->id]}" name="" />
    <UML:AssociationEnd isSpecification="false" visibility="public" ch
+angeability="changeable" isNavigable="true" xmi.id="@{[$newid++]}" ag
+gregation="none" type="@{[$asoc->c2->id]}" name="" />
   </UML:Association.connection>
  </UML:Association>
EOF

    push @aw, <<EOF;
     <assocwidget totalcounta="2" indexa="1" totalcountb="2" indexb="1
+" linewidth="none" widgetbid="@{[$asoc->c1->id]}" widgetaid="@{[$asoc
+->c2->id]}" 
xmi.id="@{[$asoc->id]}" linecolor="none" >
      <linepath>
       <startpoint startx="0" starty="0" />
       <endpoint endx="100" endy="100" />
      </linepath>
     </assocwidget>
EOF

}

$doc =~ s/__CLASES__/@c/;
$doc =~ s/__GENERAL__/@g/;
$doc =~ s/__ASOC__/@a/;
$doc =~ s/__WIDGETS__/@w/;
$doc =~ s/__ASOC_WIDGETS__/@aw/;

if ($outfile) {
    open OUT, ">", $outfile or die $!;
} else {
    *OUT = *STDOUT;
}

print OUT $doc;

close OUT;

}


sub define_doc {

$doc = <<EOF;
<?xml version="1.0" encoding="UTF-8"?>
<XMI xmlns:UML="http://schema.omg.org/spec/UML/1.3" verified="false" t
+imestamp="2007-05-16T15:42:13" xmi.version="1.2" >
 <XMI.header>
  <XMI.documentation>
   <XMI.exporter>umbrello uml modeller http://uml.sf.net</XMI.exporter
+>
   <XMI.exporterVersion>1.5.6</XMI.exporterVersion>
   <XMI.exporterEncoding>UnicodeUTF8</XMI.exporterEncoding>
  </XMI.documentation>
  <XMI.metamodel xmi.name="UML" href="UML.xml" xmi.version="1.3" />
 </XMI.header>
 <XMI.content>
  <UML:Model isSpecification="false" isLeaf="false" isRoot="false" xmi
+.id="m1" isAbstract="false" name="UML Model" >
   <UML:Namespace.ownedElement>
    <UML:Stereotype isSpecification="false" isLeaf="false" visibility=
+"public" namespace="m1" xmi.id="folder" isRoot="false" isAbstract="fa
+lse" name="folder" />
    <UML:Stereotype isSpecification="false" isLeaf="false" visibility=
+"public" namespace="m1" xmi.id="datatype" isRoot="false" isAbstract="
+false" name="datatype" />
    <UML:Model stereotype="folder" isSpecification="false" isLeaf="fal
+se" visibility="public" namespace="m1" xmi.id="Logical View" isRoot="
+false" isAbstract="false" name="Logical View" >
     <UML:Namespace.ownedElement>
      <UML:Package stereotype="folder" isSpecification="false" isLeaf=
+"false" visibility="public" namespace="Logical View" xmi.id="Datatype
+s" isRoot="false" isAbstract="false" name="Datatypes" >
       <UML:Namespace.ownedElement>
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="qmR4Tu
+vw57LZ" isRoot="false" isAbstract="false" name="int" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="piEXuo
+865Uxz" isRoot="false" isAbstract="false" name="char" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="glmMvO
+Qj8roZ" isRoot="false" isAbstract="false" name="bool" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="jhTopo
+LcUaAO" isRoot="false" isAbstract="false" name="float" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="MGTPkQ
+OR9Al5" isRoot="false" isAbstract="false" name="double" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="WBme1a
+BiIeX5" isRoot="false" isAbstract="false" name="short" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="QqhuOp
+Hk6k9q" isRoot="false" isAbstract="false" name="long" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="8YFIg0
+LDA7p9" isRoot="false" isAbstract="false" name="unsigned int" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="i1rydM
+34Diwb" isRoot="false" isAbstract="false" name="unsigned short" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="YDMevV
+S41gMi" isRoot="false" isAbstract="false" name="unsigned long" />
        <UML:DataType stereotype="datatype" isSpecification="false" is
+Leaf="false" visibility="public" namespace="Datatypes" xmi.id="efvomi
+vUjnSL" isRoot="false" isAbstract="false" name="string" />
       </UML:Namespace.ownedElement>
      </UML:Package>
        __CLASES__
        __ASOC__
     </UML:Namespace.ownedElement>
     <XMI.extension xmi.extender="umbrello" >
      <diagrams>
       <diagram snapgrid="0" showattsig="1" fillcolor="#ffffc0" linewi
+dth="0" zoom="100" showgrid="0" showopsig="1" usefillcolor="1" snapx=
+"10" canvaswidth="854" snapy="10" showatts="1" xmi.id="EHNtwEnofAc4" 
+documentation="" type="1" showops="1" showpackage="0" name="class dia
+gram" localid="" showstereotype="0" showscope="1" snapcsgrid="0" font
+="Sans Serif,10,-1,0,50,0,0,0,0,0" linecolor="#ff0000" canvasheight="
+633" >
        <widgets>
        __WIDGETS__
        </widgets>
        <messages/>
        <associations>
        __ASOC_WIDGETS__
        </associations>
       </diagram>
      </diagrams>
     </XMI.extension>
    </UML:Model>
    <UML:Model stereotype="folder" isSpecification="false" isLeaf="fal
+se" visibility="public" namespace="m1" xmi.id="Use Case View" isRoot=
+"false" isAbstract="false" name="Use Case View" >
     <UML:Namespace.ownedElement/>
    </UML:Model>
    <UML:Model stereotype="folder" isSpecification="false" isLeaf="fal
+se" visibility="public" namespace="m1" xmi.id="Component View" isRoot
+="false" isAbstract="false" name="Component View" >
     <UML:Namespace.ownedElement/>
    </UML:Model>
    <UML:Model stereotype="folder" isSpecification="false" isLeaf="fal
+se" visibility="public" namespace="m1" xmi.id="Deployment View" isRoo
+t="false" isAbstract="false" name="Deployment View" >
     <UML:Namespace.ownedElement/>
    </UML:Model>
    <UML:Model stereotype="folder" isSpecification="false" isLeaf="fal
+se" visibility="public" namespace="m1" xmi.id="Entity Relationship Mo
+del" isRoot="false" isAbstract="false" name="Entity Relationship Mode
+l" >
     <UML:Namespace.ownedElement/>
    </UML:Model>
   </UML:Namespace.ownedElement>
  </UML:Model>
 </XMI.content>
 <XMI.extensions xmi.extender="umbrello" >
  <docsettings viewid="EHNtwEnofAc4" documentation="" uniqueid="9TPKCL
+wkXIMQ" />
  <listview>
   <listitem open="1" type="800" label="Views" >
    <listitem open="1" type="801" id="Logical View" >
     <listitem open="0" type="807" id="EHNtwEnofAc4" label="class diag
+ram" />
     <listitem open="1" type="813" id="9TPKCLwkXIMQ" />
     <listitem open="0" type="830" id="Datatypes" >
      <listitem open="1" type="829" id="glmMvOQj8roZ" />
      <listitem open="1" type="829" id="piEXuo865Uxz" />
      <listitem open="1" type="829" id="MGTPkQOR9Al5" />
      <listitem open="1" type="829" id="jhTopoLcUaAO" />
      <listitem open="1" type="829" id="qmR4Tuvw57LZ" />
      <listitem open="1" type="829" id="QqhuOpHk6k9q" />
      <listitem open="1" type="829" id="WBme1aBiIeX5" />
      <listitem open="1" type="829" id="efvomivUjnSL" />
      <listitem open="1" type="829" id="8YFIg0LDA7p9" />
      <listitem open="1" type="829" id="YDMevVS41gMi" />
      <listitem open="1" type="829" id="i1rydM34Diwb" />
     </listitem>
    </listitem>
    <listitem open="1" type="802" id="Use Case View" />
    <listitem open="1" type="821" id="Component View" />
    <listitem open="1" type="827" id="Deployment View" />
    <listitem open="1" type="836" id="Entity Relationship Model" />
   </listitem>
  </listview>
  <codegeneration>
   <codegenerator language="C++" />
  </codegeneration>
 </XMI.extensions>
</XMI>

EOF

}

=head1 NAME

perl2xmi - Creates an umbrello compliant xmi document from a set of cl
+asses.

=head1 SYNOPSIS

    perl2xmi --out-file=mymodel.xmi *.pm
    perl2xmi --methods --out-file=mymodel.xmi *.pm # same, but include
+s methods
    perl2xmi --exclude="CGI|Apache|Data::Dumper" --as-text --methods *
+.pm |more  

=head1 DESCRIPTION

Create an acceptable representation of a perl object model in xmi.
By default prints the xmi document in standard output, this 
can be overwriten with the parameter --out-file. 

It's based on an umbrello document retouched incrementally. 

Classes given in command line are fully loaded and are given different
+ treatement
than classes just referenced. This automatically sets a scope for recu
+rsion.

Classes indicated on command line will ve eval'ed. May be you will nee
+d to set PERL5LIB.

Cardinality is not considered yet.

For me, this script is a good starting point, it's dirty, but works.

=head2 OPTIONS 

=over 12

=item C<--methods>

Boolean flag to include methods. These are extracted with a simple
regular expression like ^sub\s+(\w+).

=item C<--out-file>

File in wich to store the generated Document, defaults to standard out
+put.

=item C<--childs-of>

Just process classes whose parent match the given regular expression.

=item C<--exclude>

Exclude classes that match the given regular expression. 

=item C<--as-text>

Instead of generating an xmi document, it outputs a textual representa
+tion in standard
output, useful for debugging purposes.

=back

=head1 LICENSE

Released without any warranty of any kind, under the GPL license.

=head1 AUTHOR

Hans Poo- L<http://hans.opensource.cl/>
Santiago de Chile, Junio 2007

=head1 SEE ALSO

L<Devel::Symdump>

=cut

Log In?
Username:
Password:

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

How do I use this?Last hourOther CB clients
Other Users?
Others taking refuge in the Monastery: (4)
As of 2024-03-29 01:42 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    No recent polls found