package UML::Import::MetaMetaModel;

use 5.6.1;
use strict;
use warnings;

our $AUTHOR = q{ ks.perl@kurtstephens.com 2004/04/06 };
our $VERSION = do { my @r = (q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d." . "%03d" x $#r, @r };

=head1 NAME

UML::Import::MetaMetaModel - Parses an ad-hoc Metamodel description.

=head1 SYNOPSIS

  use UML::Import::MetaMetaModel;
  my $importer = UML::Import::MetaMetaModel->new('factory' => $factory);
  my $importer->import($metametamodel_desc);

=head1 DESCRIPTION

This package is used to generate a UML model from the UML 1.5 metamodel.
This model can then be passed to UML::Code::Perl or other code-generator
to generate code that represents the UML.

=head1 USAGE

=head1 EXPORT

None exported.

=head1 AUTHOR

Kurt Stephens, ks.perl@kurtstephens.com 2003/04/06

=head1 SEE ALSO

L<UML::MetaMetaModel::Factory|UML::MetaMetaModel::Factory>

=head1 VERSION

$Revision: 1.1 $

=head1 METHODS

=cut


#######################################################################

use base qw(UML::Import);

use Carp qw(confess);
use Parse::RecDescent;
use UML::MetaMetaModel::Builder;
  
#######################################################################

sub initialize
{
  my ($self) = @_;

  $self->SUPER::initialize;

  $self->{'debugParser'} ||= 0;

  $self;
}

#######################################################################
#######################################################################
# Meta-metamodel grammar
#######################################################################
#######################################################################



my $gram =
q{
  model : model_elements

  model_elements : package_element(s)

  package_element : classifier
                 | usage
		 | generalization_block
		 | association
		 | package
		 | ';'
		 
  package : 'Package' Type '{'
	        { $::builder->begin_Package($item{Type}) }
                package_element(s)
                { $::builder->end_Package }
              '}'

MetaClass : 'Class'
          | 'AssociationClass'
	  | 'Enumeration'


classifier : MetaClass Name ';'
        { 
	  $DB::single = 0; 
	  $::builder->end_Classifier($item{Name}, $item{MetaClass});
	}
      | MetaClass Name '{'
        { 
	  $DB::single = 0; 
	  $::builder->begin_Classifier($item{Name}, $item{MetaClass});
	}
          classifier_element(s)
        { $::builder->end_Classifier }
        '}'
      | MetaClass Name ':' Types ';'
        { 
	  $DB::single = 0; 
	  $::builder->end_Classifier($item{Name}, $item{MetaClass}, $item{Types});
	}
      | MetaClass Name ':' Types '{'
        { 
	  $DB::single = 0; 
	  $::builder->begin_Classifier($item{Name}, $item{MetaClass}, $item{Types});
	}
          classifier_element(s)
        { $::builder->end_Classifier }
        '}'

classifier_element : attribute 
                   | association
	           | literal
	           | classifier
	           | ';'


literal : name ';'
          { $DB::single = 0; $::builder->add_EnumerationLiteral($item{name}) }

generalization_block : ':' Types '{'
                  { $::builder->begin_Generalization_parent($item{Types}) }
                     package_element(s)
                  { $::builder->end_Generalization_parent }
                '}'

usage : '::' usage_paths ';'
            { $::builder->add_Usage(@{$item[2]}) }


attribute : visibility attribute_decl stereotype_ ';'
            { 
	      my $x = {
		'name' => $item{attribute_decl}->[0],
		'type' => $item{attribute_decl}->[1],
		'multiplicity' => $item{attribute_decl}->[2],
		'visibility' => $item{visibility},
		'stereotype' => $item{stereotype_},
	      };
	      $return = $::builder->add_Attribute($x);
	    }

attribute_decl : name ':' Type '[' multiplicity ']'
            { $return = [ $item{name}, $item{Type}, $item{multiplicity} ] }
          | name ':' Type
            { $return = [ $item{name}, $item{Type} ] }
          | name '[' multiplicity ']' ':' Type
            { $return = [ $item{name}, $item{Type}, $item{multiplicity} ] }


association : '@' association_
              { 
		my $x = {
		  'connection' => $item[2][0],
		  'name' => $item[2][1],
		  'associationClass' => $item[2][2],
		};
		$return = $::builder->add_Association($x);
	      }


association_ : '@' name association_ends
              { $return = [ $item{association_ends}, $item{name} ] }
            | '.' association_
              { 
		$item[2][2] = '.';
		$return = $item[2];
	      }
            | association_ends
              { $return = [ $item{association_ends} ] }


association_ends : association_end ',' association_ends
                   { $return = [ $item[1], @{$item[3]} ] }
                 | association_end
                   { $return = [ $item[1] ] }
                 | ';'
	           { $return = [ ] }


association_end : visibility association_end_
                  { 
		    my $x = {
		      'name'         => $item[2][0],
		      'participant'  => $item[2][1],
		      'multiplicity' => $item[2][2],
		      'visibility'   => $item{visibility},
		    };
		    #$::RD_TRACE = 1 if $x->{name} eq 'type' && $x->{'participant'} eq 'Classifier';
		    $return = $x;
		  }

association_end_ : name ':' Type multiplicity_
                   { $return = [ $item{name}, $item{Type}, $item{multiplicity_} ] }
                 | name ':' Type
                   { $return = [ $item{name}, $item{Type} ] }
                 | ':' Type multiplicity_
                   { $return = [ undef,       $item{Type}, $item{multiplicity_} ] }
                 | ':' Type 
                   { $return = [ undef,       $item{Type} ] }
                 | name multiplicity_
                   { $return = [ $item{name}, '.',          $item{multiplicity_} ] }
                 | name 
                   { $return = [ $item{name}, '.', ] }
                 | multiplicity
                   { $return = [ undef,       '.',          $item{multiplicity} ] }


multiplicity_ : multiplicity
              |  '[' multiplicity ']' { $return = $item[2]; }

#              |                       { print STDERR "No multiplicity\n"; $return = undef }

multiplicity : multiplicity_ranges

multiplicity_ranges : multiplicity_range ',' multiplicity_ranges
                      { $return = $item[1] . ',' . $item[3] }
                    | multiplicity_range
 
multiplicity_range : integer dotdot star 
                     { $return = $item[1] . '..*' }
                   | integer dotdot integer
                     { $return = $item[1] . '..' . $item[3] }
                   | star
                   | integer

stereotype_ : stereotype stereotype_    { $return = [ $item[1], @{$item[2]} ] }
            | stereotype                { $return = [ $item[1] ] }
            |                           { $return = [ ] }


visibility : '+' { $return = 'public' }
           | '-' { $return = 'private' }
           | '#' { $return = 'protected'; }
           |     { $return = $::self->{'visibility'} || 'private'; }


Types : Type ',' Types
         { $return = [ $item[1], @{$item[3]} ]; }
       | Type 
         { $return = [ $item[1] ]; }
       

 Type : name_path
 {
   my @x = split(/::/, $item[1]);
   for my $x ( @x ) {
     print STDERR "Warning: name element '$x' in '$item[1]' does not start with uppercase character\n"
     unless $x =~ /^[A-Z_]/;
   }
   # $::RD_TRACE = 1 if $item[1] eq 'Namespace';
   $return = $item[1];
 }
     | string
{
  my $x = $item[1];
  print STDERR "Warning: using string '$x' as Type name\n";
  $return = $x;
}


 Name : name_elem
 { 
   print STDERR "Warning: name '$item[1]' does not start with uppercase character\n"
   unless $item[1] =~ /^[A-Z_]/;
   $return = $item[1];
 }
 | string


 name : name_elem
 {
   print STDERR "Warning: name '$item[1]' does not start with lowercase character\n"
   unless $item[1] =~ /^[a-z_]/;
   $return = $item[1];
 } 
 | string


usage_paths : usage_path ',' usage_paths
         { $return = [ $item[1], @{$item[3]} ]; }
       | usage_path
         { $return = [ $item[1] ]; }
       
 name_path : /([a-z_][a-z_0-9]*(::[a-z_][a-z_0-9]*)*)/i
        { $return = $1; } 

 usage_path : /(([a-z_][a-z_0-9]*::)*([a-z_][a-z_0-9]*|\*))/i
        { $return = $1; } 

 name_elem : /([a-z_][a-z_0-9]*)/i
        { $return = $1; }

 string : /"([^\"]*)"/  { $return = $1; } 

 real : /([-+]?([0-9]+\.|[0-9]*\.[0-9]+)([eEgGfF][-+]?[0-9]+)?)/
{ $return = $1; }

integer : /([-+]?[0-9]+)/
{ $return = $1; }

 star : /\*/
{ $return = '*'; }

dotdot : /\.\./
{ $return = '..' }

dot : /\./
{ $return = '.' }

stereotype : /\<\<\w+\>\>/

};

#######################################################################


my $parser;
sub parser
{
  my ($self) = @_;
  
  return $parser if $parser;
  
  local $::RD_ERRORS = 1;
  local $::RD_WARN = 1;
  local $::RD_HINT = 1;
  #local $::RD_TRACE = $self->{'debugParser'} > 2;

  # $DB::single = 1;

  $parser = new Parse::RecDescent($gram) ||
  confess(code_error($@, $gram)) unless $parser;

  $parser;
}


#######################################################################


sub import_input
{
  my ($self, @args) = @_;

  my $input = join("\n", @args);
  
  $input =~ s@/\*(.*?)\*/@@sg;
  
  # print STDERR $input;

  local $::RD_ERRORS = 1;
  local $::RD_WARN = 1;
  local $::RD_HINT = 1;
  #local $::RD_TRACE = $self->{'debugParser'};

  my $builder = UML::MetaMetaModel::Builder->new('factory' => $self->factory);

  local $::self = $self;
  local $::builder = $builder;
  local $::cls;

  $builder->begin_Model();

  # $DB::single = 1;
  $self->parser->model($input);

  $builder->end_Model();

  #$DB::single = 1;

  my $model = $builder->model;

  $model;
}


####################################################################################


sub code_error
{
  my ($error, $code) = @_;
  $error ||= $@;

  my $line = 0;
  my $c = $code;
  $c = join("\n",
	    map(sprintf("%-4d ", ++ $line) . $_,
		split("\n", $code, 99999),
		),
	    '',
	    );
  my $sep = '#-' x 10;
  $c = "$sep\n$c$sep\n";
  die "$c\nin code above:\n$error";
}


####################################################################################

1;

####################################################################################


### Keep these comments at end of file: ks.perl@kurtstephens.com 2003/04/06 ###
### Local Variables: ###
### mode:perl ###
### perl-indent-level:2 ###
### perl-continued-statement-offset:0 ###
### perl-brace-offset:0 ###
### perl-label-offset:0 ###
### End: ###

