#!/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
|