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

=head1 AUTHOR

Simon Johnston (skj@acm.org)

=cut