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 |
Back to
Code Catacombs