#!/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 = <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�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 <<EOF;

perl2xmi - Creates an umbrello compliant xmi document from a set of classes.

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 methods

Create an acceptable representation of a perl object model in xmi.
By default prints the xmi document in standard output, this can be overwritten 
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 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;
<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="public" 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" visibility="public" namespace="Logical View" xmi.id="$relid" parent="@{[$parent->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" isinstance="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" namespace="Logical View" xmi.id="@{[$asoc->id]}" name="" >
   <UML:Association.connection>
	<UML:AssociationEnd isSpecification="false" visibility="public" changeability="changeable" isNavigable="true" xmi.id="@{[$newid++]}" aggregation="none" type="@{[$asoc->c1->id]}" name="" />
	<UML:AssociationEnd isSpecification="false" visibility="public" changeability="changeable" isNavigable="true" xmi.id="@{[$newid++]}" aggregation="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" timestamp="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="false" 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="false" 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="Datatypes" isRoot="false" isAbstract="false" name="Datatypes" >
       <UML:Namespace.ownedElement>
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="qmR4Tuvw57LZ" isRoot="false" isAbstract="false" name="int" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="piEXuo865Uxz" isRoot="false" isAbstract="false" name="char" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="glmMvOQj8roZ" isRoot="false" isAbstract="false" name="bool" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="jhTopoLcUaAO" isRoot="false" isAbstract="false" name="float" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="MGTPkQOR9Al5" isRoot="false" isAbstract="false" name="double" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="WBme1aBiIeX5" isRoot="false" isAbstract="false" name="short" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="QqhuOpHk6k9q" isRoot="false" isAbstract="false" name="long" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="8YFIg0LDA7p9" isRoot="false" isAbstract="false" name="unsigned int" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="i1rydM34Diwb" isRoot="false" isAbstract="false" name="unsigned short" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="YDMevVS41gMi" isRoot="false" isAbstract="false" name="unsigned long" />
        <UML:DataType stereotype="datatype" isSpecification="false" isLeaf="false" visibility="public" namespace="Datatypes" xmi.id="efvomivUjnSL" 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" linewidth="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 diagram" 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="false" 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="false" 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="false" visibility="public" namespace="m1" xmi.id="Deployment View" isRoot="false" isAbstract="false" name="Deployment View" >
     <UML:Namespace.ownedElement/>
    </UML:Model>
    <UML:Model stereotype="folder" isSpecification="false" isLeaf="false" visibility="public" namespace="m1" xmi.id="Entity Relationship Model" isRoot="false" isAbstract="false" name="Entity Relationship Model" >
     <UML:Namespace.ownedElement/>
    </UML:Model>
   </UML:Namespace.ownedElement>
  </UML:Model>
 </XMI.content>
 <XMI.extensions xmi.extender="umbrello" >
  <docsettings viewid="EHNtwEnofAc4" documentation="" uniqueid="9TPKCLwkXIMQ" />
  <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 diagram" />
     <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 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<http://hans.opensource.cl/>
Santiago de Chile, Junio 2007

=head1 SEE ALSO

L<Devel::Symdump>

=cut