#!/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|integer|less|lib|locale|open|ops|overload|re|sigtrap|sort|strict|subs|threads|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 $!; eval { require $file }; if ($@) { print STDERR "Problem requiring $file: $@. Skiping inheritance check for this module.\n"; } while ($line = ) { @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�bolos 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 <c1 eq $c1 and $_->c2 eq $c2) or ($_->c1 eq $c2 and $_->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 foreach my $method ($c->methods) { my $relid = $newid++; push @c, < EOF } push @c, < EOF foreach my $parent ($c->parents) { my $relid = $newid++; push @c, < EOF push @aw, < EOF } my $x = int(rand(800)); my $y = int(rand(800)); push @w, < EOF } foreach my $asoc (@asocs) { push @a, < EOF push @aw, < 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 = < umbrello uml modeller http://uml.sf.net 1.5.6 UnicodeUTF8 __CLASES__ __ASOC__ __WIDGETS__ __ASOC_WIDGETS__ EOF } =head1 NAME perl2xmi - Creates an umbrello compliant xmi document from a set of classes. =head1 SYNOPSIS perl2xmi --out-file=mymodel.xmi *.pm perl2xmi --methods --out-file=mymodel.xmi *.pm # same, but includes 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 recursion. Classes indicated on command line will ve eval'ed. May be you will need 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 output. =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 representation 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 Santiago de Chile, Junio 2007 =head1 SEE ALSO L =cut