package Rose;

use Win32::OLE;

my $AUTHOR = 'Simon Johnston (skj@acm.org)';
my $NAME = 'Perl REI.';
my $VERSION = '1.0.1';
$COPYRIGHT = "$NAME Version $VERSION.\nCopyright (c) $AUTHOR 2000.";

my %Types;

my $RoseApp;
my $curModel;
my $curCategory;
my $curClass;
my $curOperation;
my $curAttribute;
my $curSubsystem;
my $curModule;

my @allRelations;

sub new () {
  my $self = shift;
  my $type = ref($self) || $self;
  
  $Types{'$'} = 'String';
  $Types{'%'} = 'Hash';
  $Types{'@'} = 'Array';

  my $RoseApp = Win32::OLE->GetActiveObject('Rose.Application') 
              || Win32::OLE->new('Rose.Application');;
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $RoseApp->{'Visible'} = 1;
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curModel = $RoseApp->{'CurrentModel'};
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
  warn "Error: no Model\n" if !defined($curModel);

  $curCategory = $curModel->{'RootCategory'};
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
  warn "Error: no RootCategory\n" if !defined($curCategory);

  $curSubsystem = $curModel->{'RootSubsystem'};
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
  warn "Error: no RootSubsystem\n" if !defined($curSubsystem);

  return bless {}, $type;
}

sub CreateRootPackage () {
  my $self = shift;
  my($name) = @_;

  my @path = split /::/, $name;

  foreach $package (@path) {

    $self->NewPackage($package);
  }
}

sub NewPackage () {
  my $self = shift;
  my($name) = @_;

  $name = "_" . $name;

  $curSubsystem = $curSubsystem->AddSubsystem ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curSubsystem->SetCurrentPropertySetName ("Perl", "default");
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curCategory = $curCategory->AddCategory ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curCategory->SetCurrentPropertySetName ("Perl", "default");
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curCategory->SetAssignedSubsystem ($curSubsystem);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub PreviousPackage () {
  my $self = shift;

  $curSubsystem = $curSubsystem->{'ParentSubsystem'};
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
  warn "Error: ParentSubsystem returned undef\n" if !defined($curSubsystem);

  $curCategory = $curCategory->{'ParentCategory'};
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
  warn "Error: ParentCategory returned undef\n" if !defined($curCategory);
}

sub NewModule () {
  my $self = shift;
  my($name) = @_;

  $curModule = $curSubsystem->AddModule ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curModule->{'AssignedLanguage'} = "Perl";
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curModule->SetCurrentPropertySetName ("Perl", "default");
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
#
#  my $rdt = $curModule->{'Type'};
#  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
#
#  $rdt->{'Name'} = "PackageType";
#  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
#
#  $curModule->{'Type'} = $rdt;
#  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
#
#  $curModule->{'Part'} = "Body";
#  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub NewClass () {
  my $self = shift;
  my($name) = @_;

  print "Class: $name\n";
  $curClass = $curCategory->AddClass ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  if (!defined($curClass)) {

    $self->AddtoClass($name);
    warn "Warning: could not create class $name in $curCategory->{'Name'}\n";
  }

#  $curClass->SetCurrentPropertySetName ("Perl", "default");
#  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curClass->SetAssignedModule ($curModule);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub AddtoClass () {
  my $self = shift;
  my($name) = @_;

  my $theIndex;

  print "Adding to Class: $name\n";
  $theIndex = $curCategory->{'Classes'}->FindFirst ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curClass = $curCategory->{'Classes'}->GetAt ($theIndex);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub FindClass () {
  my $self = shift;
  my($name) = @_;

  my $rootCategory;
  my $theIndex;

  $theIndex = $curModel->{'RootCategory'}->GetAllClasses()->FindFirst ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curClass = $curModel->{'RootCategory'}->GetAllClasses()->GetAt ($theIndex);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub FindModule () {
  my $self = shift;
  my($name) = @_;

  my $theIndex;

  print "Adding to Module: $name\n";
  $theIndex = $curSubsystem->{'Modules'}->FindFirst ($name);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  $curClass = $curSubsystem->{'Modules'}->GetAt ($theIndex);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub NewOperation () {
  my $self = shift;
  my($name, $params) = @_;

  $curOperation = $curClass->AddOperation ($name, "");
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;

  if ($params ne "") {

    my @all = split /,/, $params;
    my $i = 0;
    foreach $param (@all) {

      $param =~ /^\s*([\$\%\@])([a-zA-Z_:]+)/;
      my $value = "";
      my $type  = $Types{$1};
      my $param = $2;

      if ($param ne "") {

        $curParameter = $curOperation->AddParameter($param, $type, $value, $i);
        if (Win32::OLE->LastError != 0 || !defined($curParameter)) {
  
          warn "Error: could not add parameter ($param, $type, $value, $i): " 
               . Win32::OLE->LastError ;
        }
      }
      $i++;
    }
  }
}

sub NewAttribute () {
  my $self = shift;
  my($name, $value) = @_;

  $name =~ /^([\$\%\@])([a-zA-Z_:]+)/;
  $value = "" if !defined($value);
  my $type  = $Types{$1};
  $name = $2;

  $curAttribute = $curClass->AddAttribute ($name, $type, $value);
  warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
}

sub DeferRelationship () {
  my $self = shift;
  my($left, $rel, $right) = @_;

  push @allRelations, "$left,$rel,$right";
}

sub AddDeferredRelationships () {
  my $self = shift;

  my $curAssociation;

  print "Adding relationships...\n";

  foreach $relation (@allRelations) {

    ($left,$rel,$right) = split /,/, $relation;

    if ($left =~ /\.pm$/) {

#      $self->AddtoModule($left);

#      $curAssociation = $curClass->AddAssociation($rel, $right);
#      warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
#      warn "Error: Could not create assoc between $left,$right\n "
#           if !defined($curAssociation);
    } else {

      $self->FindClass($left);

      if ($rel eq "ISA") {

        foreach my $parent (split / /, $right) {

          $curAssociation = $curClass->AddInheritRel("", $parent);
          warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
          warn "Error: Could not inherit $left from $parent\n "
               if !defined($curAssociation);
        }
      } else {

        $curAssociation = $curClass->AddAssociation($rel, $right);
        warn "Error: " . Win32::OLE->LastError if Win32::OLE->LastError != 0;
        warn "Error: Could not create assoc between $left,$right\n "
             if !defined($curAssociation);
      }
    }
  }
}

#==============================================================================
package Rose::Perl;

my $AUTHOR = 'Simon Johnston (skj@acm.org)';
my $NAME = 'Perl Reverse Engineer.';
my $VERSION = '1.0.1';
my $COPYRIGHT = "$NAME Version $VERSION.\nCopyright (c) $AUTHOR 1999-2000.";

my $Rose;

sub ReverseFile() {
  my($filename, %allpacks) = @_;

  print "File: $filename\n";

  my $relname = $filename;

  unless (open FILE, "<$filename") {
  
    warn "Can't open file $filename: $!\n";
    return ;
  }

  $Rose->NewModule($filename);

  while (<FILE>) {

    if (/^package\s+([^;]+);$/) {

      if ($allpacks{$1} == 1) {

        $relname = $1;
        $Rose->AddtoClass($1);
      } else {

        $allpacks{$1} = 1;
        $relname = $1;
        $Rose->NewClass($1);
      }
    }
    elsif (/^use\s+([^;\s]+)/) {

      $Rose->DeferRelationship($relname, "uses", $1);
    }
    elsif (/^require\s+([^;\s]+)/) {

      my $dep = $1;
      if ($1 =~ /^([\d\.]+)/) {
        $Rose->DeferRelationship($relname, "$dep", "perl");
      } else {

        $Rose->DeferRelationship($relname, "requires", $dep);
      }
    }
    elsif (/^sub\s+(\S+)/) {

      my $name   = $1;
      my $nextln = <FILE>;
      my $params = "";
      if ($nextln =~ /\(([^\)]+)\)\s*=\s*\@\_/) {

        $params = $1;
      }
      $Rose->NewOperation($name, $params);
    }
    elsif (/^BEGIN\s+{/) {

      $Rose->NewOperation("BEGIN");
    }
    elsif (/^END\s+{/) {

      $Rose->NewOperation("END");
    }
    elsif (/^([\$\%\@][a-zA-Z_:]+)(.*$)/) {

      if ($1 eq "\@ISA") {

        my @MyISA2 = eval "\@MyISA $2";

        $Rose->DeferRelationship($relname, "ISA", join(" ", @MyISA2));
      } else {

        $Rose->NewAttribute($1);
      }
    }
    elsif (/^__END__/) {

      last;
    }
  }

  close FILE;
}

sub Reverse() {
  my($directory) = @_;

  opendir DIR, $directory;

  my @allfiles = grep !/^\.\.?$/, readdir DIR;
  my %allpacks;

  foreach my $filename (@allfiles) {

    my $fullname = "$directory/$filename";
    if (-f $fullname && $filename =~ /\.pm$/) {

      &ReverseFile($fullname, %allpacks);
    }
    elsif (-d $fullname) {

      $Rose->NewPackage($filename);
      &Reverse($fullname);
      $Rose->PreviousPackage();
    }
  }

  closedir DIR;
}

sub Usage () {

  if ($ARGV[0] eq "-V") {

    print STDERR "Library:\n$Rose::COPYRIGHT\n\n";
    print STDERR "Main:\n$COPYRIGHT\n\n";
  }
  print STDERR "See POD for more information.\n";
}

sub Main () {

  if ($#ARGV < 1) {

    &Usage;
  } else {

    $Rose = Rose->new();

    if ($ARGV[0] eq "-d") {

      $Rose->CreateRootPackage($ARGV[2]) if $ARGV[2] ne "";
      &Reverse($ARGV[1]);
      $Rose->AddDeferredRelationships;
    }
    elsif ($ARGV[0] eq "-f") {

      $Rose->CreateRootPackage($ARGV[2]) if $ARGV[2] ne "";
      &ReverseFile($ARGV[1]);
      $Rose->AddDeferredRelationships;
    } else {

      &Usage;
    }
  }
}

&Main;

__END__

=head1 NAME

  preveng.pl - Reverse engineer a Perl library into Rational Rose.

=head1 SYNOPSIS

  preveng.pl -[fd] name [root::package]

=head1 DESCRIPTION

This is a subset of the RosePerl distribution on www.rationalrose.com,
which contains the wizard and forward engineering components. This 
script does run stand alone and is invoked byt the wizard. 

=head1 README

This is a subset of the RosePerl distribution on www.rationalrose.com,
which contains the wizard and forward engineering components. This 
script does run stand alone and is invoked byt the wizard. 

-f	indicates to reverse engineer a file.

-d	indicates to reverse engineer a directory (recursively)

The Reverse Engineering rules are as follows:

1.	A module is created for each “.pm” file found.
2.	Each class in the file is modeled with an assignment to the module.
3.	The ISA array (if present) is analyzed to create generalization relationships. The ISA array is not shown in the model as an attribute of the class.
4.	Exporter, EXPORT and EXPORT_OK are not used to distinguish the export control of attributes or methods.
5.	The “use” and “require” statements generate associations, with a supplier role name reflecting the statement.
6.	The special form of “require” to denote a version of the Perl interpreter is generated as a relationship to a special class “perl” with the role name reflecting the specified version number.
7.	When a “sub” is encountered the reverse engineer looks for a line that assignes values from the “@_” array. These are assumed to be parameters and an attempt is made to add them to the model. 
8.	BEGIN and END are modeled as operations; no attempt is made to analyze BEGIN for global attribute assignments.

=head1 PREREQUISITES

This script requires the C<Win32::OLE> module to talk to Rose. 

=pod OSNAMES

Win32

=pod SCRIPT CATEGORIES

Win32
UML

=head1 AUTHOR

Simon Johnston (skj@acm.org)

=cut